Commit 9934819f authored by johnleo's avatar johnleo Committed by Ben Gamari

Refactor type families in Template Haskell

Fixes #10902.

Test Plan: validate

Reviewers: goldfire, austin, hvr, jstolarek, bgamari

Reviewed By: jstolarek, bgamari

Subscribers: hvr, thomie

Differential Revision: https://phabricator.haskell.org/D1570

GHC Trac Issues: #10902
parent aaed24a4
......@@ -299,20 +299,16 @@ cvtDec (TySynInstD tc eqn)
{ tfid_inst = TyFamInstDecl { tfid_eqn = eqn'
, tfid_fvs = placeHolderNames } } }
cvtDec (OpenTypeFamilyD tc tvs result injectivity)
= do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
; result' <- cvtFamilyResultSig result
; injectivity' <- traverse cvtInjectivityAnnotation injectivity
cvtDec (OpenTypeFamilyD head)
= do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
; returnJustL $ TyClD $ FamDecl $
FamilyDecl OpenTypeFamily tc' tvs' result' injectivity' }
FamilyDecl OpenTypeFamily tc' tyvars' result' injectivity' }
cvtDec (ClosedTypeFamilyD tc tyvars result injectivity eqns)
= do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tyvars
; result' <- cvtFamilyResultSig result
cvtDec (ClosedTypeFamilyD head eqns)
= do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
; eqns' <- mapM (cvtTySynEqn tc') eqns
; injectivity' <- traverse cvtInjectivityAnnotation injectivity
; returnJustL $ TyClD $ FamDecl $
FamilyDecl (ClosedTypeFamily (Just eqns')) tc' tvs' result'
FamilyDecl (ClosedTypeFamily (Just eqns')) tc' tyvars' result'
injectivity' }
cvtDec (TH.RoleAnnotD tc roles)
......@@ -383,6 +379,19 @@ cvt_tyinst_hdr cxt tc tys
; tys' <- mapM cvtType tys
; return (cxt', tc', mkHsImplicitBndrs tys') }
----------------
cvt_tyfam_head :: TypeFamilyHead
-> CvtM ( Located RdrName
, LHsQTyVars RdrName
, Hs.LFamilyResultSig RdrName
, Maybe (Hs.LInjectivityAnn RdrName))
cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity)
= do {(_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars
; result' <- cvtFamilyResultSig result
; injectivity' <- traverse cvtInjectivityAnnotation injectivity
; return (tc', tyvars', result', injectivity') }
-------------------------------------------------------------------
-- Partitioning declarations
-------------------------------------------------------------------
......
......@@ -1114,22 +1114,19 @@ reifyTyCon tc
(filterByList ms tvs)
in (sig, inj)
; tvs' <- reifyTyVars tvs (Just tc)
; let tfHead =
TH.TypeFamilyHead (reifyName tc) tvs' resultSig injectivity
; if isOpenTypeFamilyTyCon tc
then do { fam_envs <- tcGetFamInstEnvs
; instances <- reifyFamilyInstances tc
(familyInstances fam_envs tc)
; return (TH.FamilyI
(TH.OpenTypeFamilyD (reifyName tc) tvs'
resultSig injectivity)
instances) }
; return (TH.FamilyI (TH.OpenTypeFamilyD tfHead) instances) }
else do { eqns <-
case isClosedSynFamilyTyConWithAxiom_maybe tc of
Just ax -> mapM (reifyAxBranch tc) $
fromBranches $ coAxiomBranches ax
Nothing -> return []
; return (TH.FamilyI
(TH.ClosedTypeFamilyD (reifyName tc) tvs' resultSig
injectivity eqns)
; return (TH.FamilyI (TH.ClosedTypeFamilyD tfHead eqns)
[]) } }
| isDataFamilyTyCon tc
......@@ -1234,7 +1231,8 @@ reifyClass cls
TH.TySynInstD n . TH.TySynEqn (map TH.VarT args) <$> reifyType ty
tfNames :: TH.Dec -> (TH.Name, [TH.Name])
tfNames (TH.OpenTypeFamilyD n args _ _) = (n, map bndrName args)
tfNames (TH.OpenTypeFamilyD (TH.TypeFamilyHead n args _ _))
= (n, map bndrName args)
tfNames d = pprPanic "tfNames" (text (show d))
bndrName :: TH.TyVarBndr -> TH.Name
......
......@@ -252,6 +252,11 @@ Template Haskell
- The ``Lift`` class is now derivable via the ``-XDeriveLift`` extension. See
:ref:`deriving-lift` for more information.
- The ``FamilyD`` data constructor and ``FamFlavour`` data type have
been removed. Data families are now represented by ``DataFamilyD`` and
open type families are now represented by ``OpenTypeFamilyD`` instead
of ``FamilyD``. Common elements of ``OpenTypeFamilyD`` and
``ClosedTypeFamilyD`` have been moved to ``TypeFamilyHead``.
Runtime system
~~~~~~~~~~~~~~
......
......@@ -65,7 +65,7 @@ module Language.Haskell.TH(
Dec(..), Con(..), Clause(..),
Strict(..), Foreign(..), Callconv(..), Safety(..), Pragma(..),
Inline(..), RuleMatch(..), Phases(..), RuleBndr(..), AnnTarget(..),
FunDep(..), FamFlavour(..), TySynEqn(..),
FunDep(..), FamFlavour(..), TySynEqn(..), TypeFamilyHead(..),
Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,
-- ** Expressions
Exp(..), Match(..), Body(..), Guard(..), Stmt(..), Range(..), Lit(..),
......
......@@ -452,13 +452,13 @@ dataFamilyD tc tvs kind
openTypeFamilyD :: Name -> [TyVarBndr] -> FamilyResultSig
-> Maybe InjectivityAnn -> DecQ
openTypeFamilyD tc tvs res inj
= return $ OpenTypeFamilyD tc tvs res inj
= return $ OpenTypeFamilyD (TypeFamilyHead tc tvs res inj)
closedTypeFamilyD :: Name -> [TyVarBndr] -> FamilyResultSig
-> Maybe InjectivityAnn -> [TySynEqnQ] -> DecQ
closedTypeFamilyD tc tvs result injectivity eqns =
do eqns1 <- sequence eqns
return (ClosedTypeFamilyD tc tvs result injectivity eqns1)
return (ClosedTypeFamilyD (TypeFamilyHead tc tvs result injectivity) eqns1)
-- These were deprecated in GHC 7.12 with a plan to remove them in 7.14. If you
-- remove this check please also:
......@@ -476,13 +476,14 @@ closedTypeFamilyD tc tvs result injectivity eqns =
familyNoKindD :: FamFlavour -> Name -> [TyVarBndr] -> DecQ
familyNoKindD flav tc tvs =
case flav of
TypeFam -> return $ OpenTypeFamilyD tc tvs NoSig Nothing
TypeFam -> return $ OpenTypeFamilyD (TypeFamilyHead tc tvs NoSig Nothing)
DataFam -> return $ DataFamilyD tc tvs Nothing
familyKindD :: FamFlavour -> Name -> [TyVarBndr] -> Kind -> DecQ
familyKindD flav tc tvs k =
case flav of
TypeFam -> return $ OpenTypeFamilyD tc tvs (KindSig k) Nothing
TypeFam ->
return $ OpenTypeFamilyD (TypeFamilyHead tc tvs (KindSig k) Nothing)
DataFam -> return $ DataFamilyD tc tvs (Just k)
{-# DEPRECATED closedTypeFamilyNoKindD, closedTypeFamilyKindD
......@@ -490,12 +491,13 @@ familyKindD flav tc tvs k =
closedTypeFamilyNoKindD :: Name -> [TyVarBndr] -> [TySynEqnQ] -> DecQ
closedTypeFamilyNoKindD tc tvs eqns =
do eqns1 <- sequence eqns
return (ClosedTypeFamilyD tc tvs NoSig Nothing eqns1)
return (ClosedTypeFamilyD (TypeFamilyHead tc tvs NoSig Nothing) eqns1)
closedTypeFamilyKindD :: Name -> [TyVarBndr] -> Kind -> [TySynEqnQ] -> DecQ
closedTypeFamilyKindD tc tvs kind eqns =
do eqns1 <- sequence eqns
return (ClosedTypeFamilyD tc tvs (KindSig kind) Nothing eqns1)
return (ClosedTypeFamilyD (TypeFamilyHead tc tvs (KindSig kind) Nothing)
eqns1)
roleAnnotD :: Name -> [Role] -> DecQ
roleAnnotD name roles = return $ RoleAnnotD name roles
......
......@@ -318,21 +318,15 @@ ppr_dec isTop (TySynInstD tc (TySynEqn tys rhs))
where
maybeInst | isTop = text "instance"
| otherwise = empty
ppr_dec isTop (OpenTypeFamilyD tc tvs res inj)
= text "type" <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+>
ppr res <+> maybeInj
ppr_dec isTop (OpenTypeFamilyD tfhead)
= text "type" <+> maybeFamily <+> ppr_tf_head tfhead
where
maybeFamily | isTop = text "family"
| otherwise = empty
maybeInj | (Just inj') <- inj = ppr inj'
| otherwise = empty
ppr_dec _ (ClosedTypeFamilyD tc tvs res inj eqns)
= hang (hsep [ text "type family", ppr tc, hsep (map ppr tvs), ppr res
, maybeInj, text "where" ])
ppr_dec _ (ClosedTypeFamilyD tfhead@(TypeFamilyHead tc _ _ _) eqns)
= hang (text "type family" <+> ppr_tf_head tfhead <+> text "where")
nestDepth (vcat (map ppr_eqn eqns))
where
maybeInj | (Just inj') <- inj = ppr inj'
| otherwise = empty
ppr_eqn (TySynEqn lhs rhs)
= ppr tc <+> sep (map pprParendType lhs) <+> text "=" <+> ppr rhs
......@@ -377,6 +371,13 @@ ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc
ppr_tySyn maybeInst t argsDoc rhs
= text "type" <+> maybeInst <+> ppr t <+> argsDoc <+> text "=" <+> ppr rhs
ppr_tf_head :: TypeFamilyHead -> Doc
ppr_tf_head (TypeFamilyHead tc tvs res inj)
= ppr tc <+> hsep (map ppr tvs) <+> ppr res <+> maybeInj
where
maybeInj | (Just inj') <- inj = ppr inj'
| otherwise = empty
------------------------------
instance Ppr FunDep where
ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys)
......
......@@ -1487,15 +1487,10 @@ data Dec
| TySynInstD Name TySynEqn -- ^ @{ type instance ... }@
-- | open type families (may also appear in [Dec] of 'ClassD' and 'InstanceD')
| OpenTypeFamilyD Name
[TyVarBndr] FamilyResultSig
(Maybe InjectivityAnn)
| OpenTypeFamilyD TypeFamilyHead
-- ^ @{ type family T a b c = (r :: *) | r -> a b }@
| ClosedTypeFamilyD Name
[TyVarBndr] FamilyResultSig
(Maybe InjectivityAnn)
[TySynEqn]
| ClosedTypeFamilyD TypeFamilyHead [TySynEqn]
-- ^ @{ type family F a b = (r :: *) | r -> a where ... }@
| RoleAnnotD Name [Role] -- ^ @{ type role T nominal representational }@
......@@ -1503,6 +1498,15 @@ data Dec
| DefaultSigD Name Type -- ^ @{ default size :: Data a => a -> Int }@
deriving( Show, Eq, Ord, Data, Typeable, Generic )
-- | Common elements of 'OpenTypeFamilyD' and 'ClosedTypeFamilyD'.
-- By analogy with with "head" for type classes and type class instances as
-- defined in /Type classes: an exploration of the design space/, the
-- @TypeFamilyHead@ is defined to be the elements of the declaration between
-- @type family@ and @where@.
data TypeFamilyHead =
TypeFamilyHead Name [TyVarBndr] FamilyResultSig (Maybe InjectivityAnn)
deriving( Show, Eq, Ord, Data, Typeable, Generic )
-- | One equation of a type family instance or closed type family. The
-- arguments are the left-hand-side type patterns and the right-hand-side
-- result.
......
......@@ -18,6 +18,13 @@
* Add `Show` instances for `NameFlavour` and `NameSpace`
* Remove `FamilyD` and `FamFlavour`. Add `DataFamilyD` and `OpenTypeFamilyD`
as the representation of data families and open type families
respectively. (#6018)
* Add `TypeFamilyHead` for common elements of `OpenTypeFamilyD` and
`ClosedTypeFamilyD` (#10902)
* TODO: document API changes and important bugfixes
......
......@@ -8,7 +8,8 @@ $( do { cls_nm <- newName "C"
; k_nm <- newName "k"
; f_nm <- newName "F"
; return [ClassD [] cls_nm [KindedTV a_nm (VarT k_nm)] []
[OpenTypeFamilyD f_nm [] (KindSig (VarT k_nm)) Nothing ]] } )
[OpenTypeFamilyD
(TypeFamilyHead f_nm [] (KindSig (VarT k_nm)) Nothing)]]})
-- Splices in:
-- class C (a :: k) where
......
T9160.hs:18:12: error:
T9160.hs:19:12: error:
Expecting one more argument to ‘Maybe’
Expected a type, but ‘Maybe’ has kind ‘* -> *’
In the type ‘Maybe’
......
......@@ -5,11 +5,12 @@ module ClosedFam2 where
import Language.Haskell.TH
$( return [ ClosedTypeFamilyD
(mkName "Equals")
[ KindedTV (mkName "a") (VarT (mkName "k"))
, KindedTV (mkName "b") (VarT (mkName "k")) ]
( TyVarSig (KindedTV (mkName "r") (VarT (mkName "k"))))
Nothing
(TypeFamilyHead
(mkName "Equals")
[ KindedTV (mkName "a") (VarT (mkName "k"))
, KindedTV (mkName "b") (VarT (mkName "k")) ]
( TyVarSig (KindedTV (mkName "r") (VarT (mkName "k"))))
Nothing)
[ TySynEqn [ (VarT (mkName "a"))
, (VarT (mkName "a")) ]
(ConT (mkName "Int"))
......
......@@ -9,6 +9,6 @@ import GHC.TypeLits
-- caused a crash, because it has no equations
$(do x <- reify ''(+)
case x of
FamilyI (ClosedTypeFamilyD _ _ _ _ []) _ -> return []
_ -> error $ show x
FamilyI (ClosedTypeFamilyD _ []) _ -> return []
_ -> error $ show x
)
......@@ -12,12 +12,12 @@ import Language.Haskell.TH
-- type instance F Char Bool Int = Int
-- type instance F Bool Int Char = Char
$( return
[ OpenTypeFamilyD
[ OpenTypeFamilyD (TypeFamilyHead
(mkName "F")
[ PlainTV (mkName "a"), PlainTV (mkName "b"), PlainTV (mkName "c") ]
(TyVarSig (KindedTV (mkName "result") (VarT (mkName "k"))))
(Just $ InjectivityAnn (mkName "result")
[(mkName "a"), (mkName "b"), (mkName "c") ])
[(mkName "a"), (mkName "b"), (mkName "c") ]))
, TySynInstD
(mkName "F")
(TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char")
......@@ -41,11 +41,11 @@ $( return
-- type family J a (b :: k) = r | r -> a
---type instance J Int b = Char
$( return
[ OpenTypeFamilyD
[ OpenTypeFamilyD (TypeFamilyHead
(mkName "J")
[ PlainTV (mkName "a"), KindedTV (mkName "b") (VarT (mkName "k")) ]
(TyVarSig (PlainTV (mkName "r")))
(Just $ InjectivityAnn (mkName "r") [mkName "a"])
(Just $ InjectivityAnn (mkName "r") [mkName "a"]))
, TySynInstD
(mkName "J")
(TySynEqn [ ConT (mkName "Int"), VarT (mkName "b") ]
......@@ -60,12 +60,12 @@ $( return
-- IClosed Bool Int Int = Int
$( return
[ ClosedTypeFamilyD
[ ClosedTypeFamilyD (TypeFamilyHead
(mkName "I")
[ KindedTV (mkName "a") StarT, KindedTV (mkName "b") StarT
, KindedTV (mkName "c") StarT ]
(TyVarSig (PlainTV (mkName "r")))
(Just $ InjectivityAnn (mkName "r") [(mkName "a"), (mkName "b")])
(Just $ InjectivityAnn (mkName "r") [(mkName "a"), (mkName "b")]))
[ TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char")
, ConT (mkName "Bool")]
( ConT (mkName "Bool"))
......@@ -79,7 +79,7 @@ $( return
] )
-- reification test
$( do { decl@([ClosedTypeFamilyD _ _ _ (Just inj) _]) <-
$( do { decl@([ClosedTypeFamilyD (TypeFamilyHead _ _ _ (Just inj)) _]) <-
[d| type family Bak a = r | r -> a where
Bak Int = Char
Bak Char = Int
......@@ -95,12 +95,12 @@ $( do { decl@([ClosedTypeFamilyD _ _ _ (Just inj) _]) <-
-- type instance I Int Int Int = Bool
-- type instance I Bool Int Int = Int
$( return
[ OpenTypeFamilyD
[ OpenTypeFamilyD (TypeFamilyHead
(mkName "H")
[ PlainTV (mkName "a"), PlainTV (mkName "b"), PlainTV (mkName "c") ]
(TyVarSig (PlainTV (mkName "r")))
(Just $ InjectivityAnn (mkName "r")
[(mkName "a"), (mkName "b") ])
[(mkName "a"), (mkName "b") ]))
, TySynInstD
(mkName "H")
(TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char")
......
......@@ -12,6 +12,6 @@ $(x)
-- subsequently be reified
$(do f <- reify ''F
case f of
FamilyI (ClosedTypeFamilyD _ _ _ _ []) _ -> return []
_ -> error $ show f
FamilyI (ClosedTypeFamilyD _ []) _ -> return []
_ -> error $ show f
)
......@@ -3,4 +3,4 @@ module T8028a where
import Language.Haskell.TH
x = do n <- newName "F"
return [ClosedTypeFamilyD n [] NoSig Nothing []]
return [ClosedTypeFamilyD (TypeFamilyHead n [] NoSig Nothing) []]
......@@ -11,14 +11,16 @@ type family Foo a = r | r -> a where
type family Baz (a :: k) = (r :: k) | r -> a
type instance Baz x = x
$( do FamilyI foo@(ClosedTypeFamilyD _ tvbs1 res1 m_kind1 eqns1)
$( do FamilyI foo@(ClosedTypeFamilyD (TypeFamilyHead _ tvbs1 res1 m_kind1) eqs1)
[] <- reify ''Foo
FamilyI baz@(OpenTypeFamilyD _ tvbs2 res2 m_kind2)
FamilyI baz@(OpenTypeFamilyD (TypeFamilyHead _ tvbs2 res2 m_kind2))
[inst@(TySynInstD _ eqn2)] <- reify ''Baz
runIO $ putStrLn $ pprint foo
runIO $ putStrLn $ pprint baz
runIO $ putStrLn $ pprint inst
runIO $ hFlush stdout
return [ ClosedTypeFamilyD (mkName "Foo'") tvbs1 res1 m_kind1 eqns1
, OpenTypeFamilyD (mkName "Baz'") tvbs2 res2 m_kind2
return [ ClosedTypeFamilyD
(TypeFamilyHead (mkName "Foo'") tvbs1 res1 m_kind1) eqs1
, OpenTypeFamilyD
(TypeFamilyHead (mkName "Baz'") tvbs2 res2 m_kind2)
, TySynInstD (mkName "Baz'") eqn2 ] )
......@@ -12,13 +12,14 @@ import Data.Char
import Data.List
import Language.Haskell.TH
$(return [OpenTypeFamilyD (mkName "Map") [KindedTV (mkName "f")
(AppT (AppT ArrowT (VarT (mkName "k1")))
(VarT (mkName "k2"))),
KindedTV (mkName "l")
(AppT ListT
(VarT (mkName "k1")))]
(KindSig (AppT ListT (VarT (mkName "k2")))) Nothing])
$(return [OpenTypeFamilyD (TypeFamilyHead
(mkName "Map") [KindedTV (mkName "f")
(AppT (AppT ArrowT (VarT (mkName "k1")))
(VarT (mkName "k2"))),
KindedTV (mkName "l")
(AppT ListT
(VarT (mkName "k1")))]
(KindSig (AppT ListT (VarT (mkName "k2")))) Nothing)])
$( let fixKs :: String -> String -- need to remove TH renaming index from k variables
fixKs s =
......
TH_RichKinds2.hs:23:4: Warning:
TH_RichKinds2.hs:24:4: Warning:
data SMaybe_0 (t_1 :: k_0 -> *) (t_3 :: GHC.Base.Maybe k_0)
= forall . t_3 ~ 'GHC.Base.Nothing => SNothing_4
| forall a_5 . t_3 ~ 'GHC.Base.Just a_5 => SJust_6 (t_1 a_5)
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment