Commit cac0795a authored by Jan Stolarek's avatar Jan Stolarek

Change Template Haskell representation of GADTs.

Previous representation of GADTs in TH was not expressive enough
to express possible GADT return types. See #11341

Test Plan: ./validate

Reviewers: goldfire, austin, bgamari

Subscribers: thomie, RyanGlScott

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

GHC Trac Issues: #11341
parent 852b6030
...@@ -1964,21 +1964,20 @@ repConstr (PrefixCon ps) Nothing [con] ...@@ -1964,21 +1964,20 @@ repConstr (PrefixCon ps) Nothing [con]
= do arg_tys <- repList bangTypeQTyConName repBangTy ps = do arg_tys <- repList bangTypeQTyConName repBangTy ps
rep2 normalCName [unC con, unC arg_tys] rep2 normalCName [unC con, unC arg_tys]
repConstr (PrefixCon ps) (Just res_ty) cons repConstr (PrefixCon ps) (Just (L _ res_ty)) cons
= do arg_tys <- repList bangTypeQTyConName repBangTy ps = do arg_tys <- repList bangTypeQTyConName repBangTy ps
(res_n, idx) <- repGadtReturnTy res_ty res_ty' <- repTy res_ty
rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_n rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty']
, unC idx]
repConstr (RecCon (L _ ips)) resTy cons repConstr (RecCon (L _ ips)) resTy cons
= do args <- concatMapM rep_ip ips = do args <- concatMapM rep_ip ips
arg_vtys <- coreList varBangTypeQTyConName args arg_vtys <- coreList varBangTypeQTyConName args
case resTy of case resTy of
Nothing -> rep2 recCName [unC (head cons), unC arg_vtys] Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]
Just res_ty -> do Just (L _ res_ty) -> do
(res_n, idx) <- repGadtReturnTy res_ty res_ty' <- repTy res_ty
rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys, rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys,
unC res_n, unC idx] unC res_ty']
where where
rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip) rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
...@@ -1996,15 +1995,6 @@ repConstr (InfixCon st1 st2) Nothing [con] ...@@ -1996,15 +1995,6 @@ repConstr (InfixCon st1 st2) Nothing [con]
repConstr (InfixCon {}) (Just _) _ = panic "repConstr: infix GADT constructor?" repConstr (InfixCon {}) (Just _) _ = panic "repConstr: infix GADT constructor?"
repConstr _ _ _ = panic "repConstr: invariant violated" repConstr _ _ _ = panic "repConstr: invariant violated"
repGadtReturnTy :: LHsType Name -> DsM (Core TH.Name, Core [TH.TypeQ])
repGadtReturnTy res_ty | Just (n, tys) <- hsTyGetAppHead_maybe res_ty
= do { n' <- lookupLOcc n
; tys' <- repList typeQTyConName repLTy tys
; return (n', tys') }
repGadtReturnTy res_ty
= failWithDs (ptext (sLit "Malformed constructor result type:")
<+> ppr res_ty)
------------ Types ------------------- ------------ Types -------------------
repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ
......
...@@ -189,10 +189,10 @@ cvtDec (TySynD tc tvs rhs) ...@@ -189,10 +189,10 @@ cvtDec (TySynD tc tvs rhs)
, tcdRhs = rhs' } } , tcdRhs = rhs' } }
cvtDec (DataD ctxt tc tvs ksig constrs derivs) cvtDec (DataD ctxt tc tvs ksig constrs derivs)
= do { let isGadtCon (GadtC _ _ _ _) = True = do { let isGadtCon (GadtC _ _ _) = True
isGadtCon (RecGadtC _ _ _ _) = True isGadtCon (RecGadtC _ _ _) = True
isGadtCon (ForallC _ _ c ) = isGadtCon c isGadtCon (ForallC _ _ c) = isGadtCon c
isGadtCon _ = False isGadtCon _ = False
isGadtDecl = all isGadtCon constrs isGadtDecl = all isGadtCon constrs
isH98Decl = all (not . isGadtCon) constrs isH98Decl = all (not . isGadtCon) constrs
; unless (isGadtDecl || isH98Decl) ; unless (isGadtDecl || isH98Decl)
...@@ -480,22 +480,18 @@ cvtConstr (ForallC tvs ctxt con) ...@@ -480,22 +480,18 @@ cvtConstr (ForallC tvs ctxt con)
unLoc (fromMaybe (noLoc []) unLoc (fromMaybe (noLoc [])
(con_cxt con'))) } } (con_cxt con'))) } }
cvtConstr (GadtC c strtys ty idx) cvtConstr (GadtC c strtys ty)
= do { c' <- mapM cNameL c = do { c' <- mapM cNameL c
; args <- mapM cvt_arg strtys ; args <- mapM cvt_arg strtys
; idx' <- mapM cvtType idx ; L _ ty' <- cvtType ty
; ty' <- tconNameL ty ; c_ty <- mk_arr_apps args ty'
; L _ ret_ty <- mk_apps (HsTyVar ty') idx'
; c_ty <- mk_arr_apps args ret_ty
; returnL $ mkGadtDecl c' (mkLHsSigType c_ty)} ; returnL $ mkGadtDecl c' (mkLHsSigType c_ty)}
cvtConstr (RecGadtC c varstrtys ty idx) cvtConstr (RecGadtC c varstrtys ty)
= do { c' <- mapM cNameL c = do { c' <- mapM cNameL c
; ty' <- tconNameL ty ; ty' <- cvtType ty
; rec_flds <- mapM cvt_id_arg varstrtys ; rec_flds <- mapM cvt_id_arg varstrtys
; idx' <- mapM cvtType idx ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty')
; ret_ty <- mk_apps (HsTyVar ty') idx'
; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ret_ty)
; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) } ; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) }
cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
......
...@@ -13,6 +13,7 @@ TcSplice: Template Haskell splices ...@@ -13,6 +13,7 @@ TcSplice: Template Haskell splices
{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE MultiWayIf #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module TcSplice( module TcSplice(
...@@ -1338,41 +1339,42 @@ reifyDataCon isGadtDataCon tys dc ...@@ -1338,41 +1339,42 @@ reifyDataCon isGadtDataCon tys dc
(ex_tvs, theta, arg_tys) (ex_tvs, theta, arg_tys)
= dataConInstSig dc tys = dataConInstSig dc tys
-- used for GADTs data constructors -- used for GADTs data constructors
(g_univ_tvs, g_ex_tvs, g_eq_spec, g_theta, g_arg_tys, _) (g_univ_tvs, g_ex_tvs, g_eq_spec, g_theta, g_arg_tys, g_res_ty)
= dataConFullSig dc = dataConFullSig dc
(srcUnpks, srcStricts) (srcUnpks, srcStricts)
= mapAndUnzip reifySourceBang (dataConSrcBangs dc) = mapAndUnzip reifySourceBang (dataConSrcBangs dc)
dcdBangs = zipWith TH.Bang srcUnpks srcStricts dcdBangs = zipWith TH.Bang srcUnpks srcStricts
fields = dataConFieldLabels dc fields = dataConFieldLabels dc
name = reifyName dc name = reifyName dc
r_ty_name = reifyName (dataConTyCon dc) -- return type for GADTs -- Universal tvs present in eq_spec need to be filtered out, as
-- return type indices -- they will not appear anywhere in the type.
subst = mkTopTCvSubst (map eqSpecPair g_eq_spec) subst = mkTopTCvSubst (map eqSpecPair g_eq_spec)
idx = substTyVars subst g_univ_tvs
-- universal tvs that were not substituted
g_unsbst_univ_tvs = filter (`notElemTCvSubst` subst) g_univ_tvs g_unsbst_univ_tvs = filter (`notElemTCvSubst` subst) g_univ_tvs
; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys) ; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys)
; idx_tys <- reifyTypes idx
; let [r_a1, r_a2] = r_arg_tys
; let main_con | not (null fields) && not isGadtDataCon
= TH.RecC name (zip3 (map reifyFieldLabel fields)
dcdBangs r_arg_tys)
| not (null fields)
= TH.RecGadtC [name]
(zip3 (map (reifyName . flSelector) fields)
dcdBangs r_arg_tys) r_ty_name idx_tys
| dataConIsInfix dc
= ASSERT( length arg_tys == 2 )
TH.InfixC (s1,r_a1) name (s2,r_a2)
| isGadtDataCon
= TH.GadtC [name] (dcdBangs `zip` r_arg_tys) r_ty_name
idx_tys
| otherwise
= TH.NormalC name (dcdBangs `zip` r_arg_tys)
[r_a1, r_a2] = r_arg_tys
[s1, s2] = dcdBangs [s1, s2] = dcdBangs
(ex_tvs', theta') | isGadtDataCon = ( g_unsbst_univ_tvs ++ g_ex_tvs
; main_con <-
if | not (null fields) && not isGadtDataCon ->
return $ TH.RecC name (zip3 (map reifyFieldLabel fields)
dcdBangs r_arg_tys)
| not (null fields) -> do
{ res_ty <- reifyType g_res_ty
; return $ TH.RecGadtC [name]
(zip3 (map (reifyName . flSelector) fields)
dcdBangs r_arg_tys) res_ty }
| dataConIsInfix dc ->
ASSERT( length arg_tys == 2 )
return $ TH.InfixC (s1,r_a1) name (s2,r_a2)
| isGadtDataCon -> do
{ res_ty <- reifyType g_res_ty
; return $ TH.GadtC [name] (dcdBangs `zip` r_arg_tys) res_ty }
| otherwise ->
return $ TH.NormalC name (dcdBangs `zip` r_arg_tys)
; let (ex_tvs', theta') | isGadtDataCon = ( g_unsbst_univ_tvs ++ g_ex_tvs
, g_theta ) , g_theta )
| otherwise = ( ex_tvs, theta ) | otherwise = ( ex_tvs, theta )
ret_con | null ex_tvs' && null theta' = return main_con ret_con | null ex_tvs' && null theta' = return main_con
......
...@@ -11,7 +11,7 @@ module Language.Haskell.TH.Lib where ...@@ -11,7 +11,7 @@ module Language.Haskell.TH.Lib where
import Language.Haskell.TH.Syntax hiding (Role, InjectivityAnn) import Language.Haskell.TH.Syntax hiding (Role, InjectivityAnn)
import qualified Language.Haskell.TH.Syntax as TH import qualified Language.Haskell.TH.Syntax as TH
import Control.Monad( liftM, liftM2, liftM3 ) import Control.Monad( liftM, liftM2 )
import Data.Word( Word8 ) import Data.Word( Word8 )
---------------------------------------------------------- ----------------------------------------------------------
...@@ -550,13 +550,11 @@ infixC st1 con st2 = do st1' <- st1 ...@@ -550,13 +550,11 @@ infixC st1 con st2 = do st1' <- st1
forallC :: [TyVarBndr] -> CxtQ -> ConQ -> ConQ forallC :: [TyVarBndr] -> CxtQ -> ConQ -> ConQ
forallC ns ctxt con = liftM2 (ForallC ns) ctxt con forallC ns ctxt con = liftM2 (ForallC ns) ctxt con
gadtC :: [Name] -> [StrictTypeQ] -> Name -> [TypeQ] -> ConQ gadtC :: [Name] -> [StrictTypeQ] -> TypeQ -> ConQ
gadtC cons strtys ty idx = liftM3 (GadtC cons) (sequence strtys) gadtC cons strtys ty = liftM2 (GadtC cons) (sequence strtys) ty
(return ty) (sequence idx)
recGadtC :: [Name] -> [VarStrictTypeQ] -> Name -> [TypeQ] -> ConQ recGadtC :: [Name] -> [VarStrictTypeQ] -> TypeQ -> ConQ
recGadtC cons varstrtys ty idx = liftM3 (RecGadtC cons) (sequence varstrtys) recGadtC cons varstrtys ty = liftM2 (RecGadtC cons) (sequence varstrtys) ty
(return ty) (sequence idx)
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- * Type -- * Type
......
...@@ -361,10 +361,10 @@ ppr_data maybeInst ctxt t argsDoc ksig cs decs ...@@ -361,10 +361,10 @@ ppr_data maybeInst ctxt t argsDoc ksig cs decs
isGadtDecl :: Bool isGadtDecl :: Bool
isGadtDecl = not (null cs) && all isGadtCon cs isGadtDecl = not (null cs) && all isGadtCon cs
where isGadtCon (GadtC _ _ _ _ ) = True where isGadtCon (GadtC _ _ _ ) = True
isGadtCon (RecGadtC _ _ _ _) = True isGadtCon (RecGadtC _ _ _) = True
isGadtCon (ForallC _ _ x ) = isGadtCon x isGadtCon (ForallC _ _ x ) = isGadtCon x
isGadtCon _ = False isGadtCon _ = False
ksigDoc = case ksig of ksigDoc = case ksig of
Nothing -> empty Nothing -> empty
...@@ -506,38 +506,38 @@ instance Ppr Con where ...@@ -506,38 +506,38 @@ instance Ppr Con where
<+> pprName' Infix c <+> pprName' Infix c
<+> pprBangType st2 <+> pprBangType st2
ppr (ForallC ns ctxt (GadtC c sts ty idx)) ppr (ForallC ns ctxt (GadtC c sts ty))
= commaSep c <+> dcolon <+> pprForall ns ctxt <+> pprGadtRHS sts ty idx = commaSep c <+> dcolon <+> pprForall ns ctxt <+> pprGadtRHS sts ty
ppr (ForallC ns ctxt (RecGadtC c vsts ty idx)) ppr (ForallC ns ctxt (RecGadtC c vsts ty))
= commaSep c <+> dcolon <+> pprForall ns ctxt = commaSep c <+> dcolon <+> pprForall ns ctxt
<+> pprRecFields vsts ty idx <+> pprRecFields vsts ty
ppr (ForallC ns ctxt con) ppr (ForallC ns ctxt con)
= pprForall ns ctxt <+> ppr con = pprForall ns ctxt <+> ppr con
ppr (GadtC c sts ty idx) ppr (GadtC c sts ty)
= commaSep c <+> dcolon <+> pprGadtRHS sts ty idx = commaSep c <+> dcolon <+> pprGadtRHS sts ty
ppr (RecGadtC c vsts ty idx) ppr (RecGadtC c vsts ty)
= commaSep c <+> dcolon <+> pprRecFields vsts ty idx = commaSep c <+> dcolon <+> pprRecFields vsts ty
pprForall :: [TyVarBndr] -> Cxt -> Doc pprForall :: [TyVarBndr] -> Cxt -> Doc
pprForall ns ctxt pprForall ns ctxt
= text "forall" <+> hsep (map ppr ns) = text "forall" <+> hsep (map ppr ns)
<+> char '.' <+> pprCxt ctxt <+> char '.' <+> pprCxt ctxt
pprRecFields :: [(Name, Strict, Type)] -> Name -> [Type] -> Doc pprRecFields :: [(Name, Strict, Type)] -> Type -> Doc
pprRecFields vsts ty idx pprRecFields vsts ty
= braces (sep (punctuate comma $ map pprVarBangType vsts)) = braces (sep (punctuate comma $ map pprVarBangType vsts))
<+> arrow <+> ppr ty <+> sep (map ppr idx) <+> arrow <+> ppr ty
pprGadtRHS :: [(Strict, Type)] -> Name -> [Type] -> Doc pprGadtRHS :: [(Strict, Type)] -> Type -> Doc
pprGadtRHS [] ty idx pprGadtRHS [] ty
= ppr ty <+> sep (map ppr idx) = ppr ty
pprGadtRHS sts ty idx pprGadtRHS sts ty
= sep (punctuate (space <> arrow) (map pprBangType sts)) = sep (punctuate (space <> arrow) (map pprBangType sts))
<+> arrow <+> ppr ty <+> sep (map ppr idx) <+> arrow <+> ppr ty
------------------------------ ------------------------------
pprVarBangType :: VarBangType -> Doc pprVarBangType :: VarBangType -> Doc
...@@ -615,6 +615,9 @@ pprParendType WildCardT = char '_' ...@@ -615,6 +615,9 @@ pprParendType WildCardT = char '_'
pprParendType (InfixT x n y) = parens (ppr x <+> pprName' Infix n <+> ppr y) pprParendType (InfixT x n y) = parens (ppr x <+> pprName' Infix n <+> ppr y)
pprParendType t@(UInfixT {}) = parens (pprUInfixT t) pprParendType t@(UInfixT {}) = parens (pprUInfixT t)
pprParendType (ParensT t) = ppr t pprParendType (ParensT t) = ppr t
pprParendType tuple | (TupleT n, args) <- split tuple
, length args == n
= parens (commaSep args)
pprParendType other = parens (ppr other) pprParendType other = parens (ppr other)
pprUInfixT :: Type -> Doc pprUInfixT :: Type -> Doc
......
...@@ -1632,25 +1632,40 @@ data Con = NormalC Name [BangType] -- ^ @C Int a@ ...@@ -1632,25 +1632,40 @@ data Con = NormalC Name [BangType] -- ^ @C Int a@
| InfixC BangType Name BangType -- ^ @Int :+ a@ | InfixC BangType Name BangType -- ^ @Int :+ a@
| ForallC [TyVarBndr] Cxt Con -- ^ @forall a. Eq a => C [a]@ | ForallC [TyVarBndr] Cxt Con -- ^ @forall a. Eq a => C [a]@
| GadtC [Name] [BangType] | GadtC [Name] [BangType]
Name -- See Note [GADT return type] Type -- See Note [GADT return type]
[Type] -- Indices of the type constructor
-- ^ @C :: a -> b -> T b Int@ -- ^ @C :: a -> b -> T b Int@
| RecGadtC [Name] [VarBangType] | RecGadtC [Name] [VarBangType]
Name -- See Note [GADT return type] Type -- See Note [GADT return type]
[Type] -- Indices of the type constructor
-- ^ @C :: { v :: Int } -> T b Int@ -- ^ @C :: { v :: Int } -> T b Int@
deriving (Show, Eq, Ord, Data, Typeable, Generic) deriving (Show, Eq, Ord, Data, Typeable, Generic)
-- Note [GADT return type] -- Note [GADT return type]
-- ~~~~~~~~~~~~~~~~~~~~~~~ -- ~~~~~~~~~~~~~~~~~~~~~~~
-- --
-- The name of the return type stored by a GADT constructor does not necessarily -- The return type of a GADT constructor does not necessarily match the name of
-- match the name of the data type: -- the data type:
-- --
-- type S = T -- type S = T
-- --
-- data T a where -- data T a where
-- MkT :: S Int -- MkT :: S Int
--
--
-- type S a = T
--
-- data T a where
-- MkT :: S Char Int
--
--
-- type Id a = a
-- type S a = T
--
-- data T a where
-- MkT :: Id (S Char Int)
--
--
-- That is why we allow the return type stored by a constructor to be an
-- arbitrary type. See also #11341
data Bang = Bang SourceUnpackedness SourceStrictness data Bang = Bang SourceUnpackedness SourceStrictness
-- ^ @C { {\-\# UNPACK \#-\} !}a@ -- ^ @C { {\-\# UNPACK \#-\} !}a@
......
...@@ -40,8 +40,8 @@ $( return ...@@ -40,8 +40,8 @@ $( return
, VarT (mkName "a") , VarT (mkName "a")
) )
] ]
( mkName "T" ) (AppT (ConT (mkName "T"))
[ VarT (mkName "a") ] (VarT (mkName "a")))
, ForallC [PlainTV (mkName "a"), PlainTV (mkName "b")] , ForallC [PlainTV (mkName "a"), PlainTV (mkName "b")]
[AppT (AppT EqualityT (VarT $ mkName "a" ) ) [AppT (AppT EqualityT (VarT $ mkName "a" ) )
(ConT $ mkName "Int") ] $ (ConT $ mkName "Int") ] $
...@@ -55,8 +55,8 @@ $( return ...@@ -55,8 +55,8 @@ $( return
, VarT (mkName "b") , VarT (mkName "b")
) )
] ]
( mkName "T" ) (AppT (ConT (mkName "T"))
[ ConT (mkName "Int") ] ] (ConT (mkName "Int"))) ]
[] ]) [] ])
$( do { -- test reification $( do { -- test reification
......
...@@ -15,86 +15,3 @@ data T'_0 a_1 :: * where ...@@ -15,86 +15,3 @@ data T'_0 a_1 :: * where
MkT'_2 :: forall a_3 . a_3 -> a_3 -> T'_0 a_3 MkT'_2 :: forall a_3 . a_3 -> a_3 -> T'_0 a_3
MkC'_4 :: forall a_5 b_6 . a_5 ~ GHC.Types.Int => {foo_7 :: a_5, MkC'_4 :: forall a_5 b_6 . a_5 ~ GHC.Types.Int => {foo_7 :: a_5,
bar_8 :: b_6} -> T'_0 GHC.Types.Int bar_8 :: b_6} -> T'_0 GHC.Types.Int
TYPE SIGNATURES
TYPE CONSTRUCTORS
type role Bar representational phantom
newtype Bar a (b :: Bool) where
MkBar :: a -> Bar a b
Kind: GHC.Types.Type -> Bool -> GHC.Types.Type
data family D a0 b
data E where
MkE :: a0 -> E
Kind: *
type role Foo representational phantom
data Foo a0 b0 where
MkFoo :: a0 -> Foo a0 b0
MkFoo' :: a0 -> Foo a0 b0
Kind: * -> * -> *
type role T nominal
data T a where
MkT :: a -> a -> T a
MkC :: a1 ~ Int => {foo :: a1, bar :: b} -> T Int
Kind: * -> GHC.Types.Type
COERCION AXIOMS
axiom T10828.NTCo:Bar :: Bar a b = a -- Defined at T10828.hs:9:4
axiom T10828.TFCo:R:DIntBool ::
D Int Bool = T10828.R:DIntBool -- Defined at T10828.hs:9:4
FAMILY INSTANCES
data instance D Int Bool
Dependent modules: []
Dependent packages: [array-<VERSION>, base-<VERSION>, binary-<VERSION>,
bytestring-<VERSION>, containers-<VERSION>, deepseq-<VERSION>,
ghc-boot-<VERSION>, ghc-prim-<VERSION>, integer-<IMPL>-<VERSION>,
pretty-<VERSION>, template-haskell-<VERSION>]
==================== Typechecker ====================
foo = ()
bar = ()
T10828.$tcT
= GHC.Types.TyCon 0## 0## T10828.$trModule
(GHC.Types.TrNameS "T"#)
T10828.$tc'MkT
= GHC.Types.TyCon
0## 0## T10828.$trModule
(GHC.Types.TrNameS "'MkT"#)
T10828.$tc'MkC
= GHC.Types.TyCon
0## 0## T10828.$trModule
(GHC.Types.TrNameS "'MkC"#)
T10828.$tc'DInt
= GHC.Types.TyCon
0## 0## T10828.$trModule
(GHC.Types.TrNameS "'DInt"#)
T10828.$tcBar
= GHC.Types.TyCon
0## 0## T10828.$trModule
(GHC.Types.TrNameS "Bar"#)
T10828.$tc'MkBar
= GHC.Types.TyCon
0## 0## T10828.$trModule
(GHC.Types.TrNameS "'MkBar"#)
T10828.$tcFoo
= GHC.Types.TyCon
0## 0## T10828.$trModule
(GHC.Types.TrNameS "Foo"#)
T10828.$tc'MkFoo
= GHC.Types.TyCon
0## 0## T10828.$trModule
(GHC.Types.TrNameS "'MkFoo"#)
T10828.$tc'MkFoo'
= GHC.Types.TyCon
0## 0## T10828.$trModule
(GHC.Types.TrNameS "'MkFoo'"#)
T10828.$tcE
= GHC.Types.TyCon 0## 0## T10828.$trModule
(GHC.Types.TrNameS "E"#)
T10828.$tc'MkE
= GHC.Types.TyCon
0## 0## T10828.$trModule
(GHC.Types.TrNameS "'MkE"#)
T10828.$tcD
= GHC.Types.TyCon 0## 0## T10828.$trModule
(GHC.Types.TrNameS "D"#)
T10828.$trModule
= GHC.Types.Module
(GHC.Types.TrNameS "main"#) (GHC.Types.TrNameS "T10828"#)
...@@ -33,7 +33,7 @@ $( return ...@@ -33,7 +33,7 @@ $( return
, VarT (mkName "b") , VarT (mkName "b")
) )
] ]
( mkName "T" ) (AppT (ConT (mkName "T"))
[ ConT (mkName "Int") ] (ConT (mkName "Int")))
] ]
[] ]) [] ])
{-# LANGUAGE GADTs, TemplateHaskell #-}
module T11341 where
import Language.Haskell.TH
import System.IO
type S1 = T1
data T1 a where
MkT1 :: S1 Int
type S2 a = T2
data T2 a where
MkT2 :: S2 Char Int
type Id a = a
type S3 a = T3
data T3 a where
MkT3 :: Id (S3 Char Int)
$( do -- test reification
{ TyConI dec <- runQ $ reify (mkName "T1")
; runIO $ putStrLn (pprint dec) >> hFlush stdout
; TyConI dec <- runQ $ reify (mkName "T2")
; runIO $ putStrLn (pprint dec) >> hFlush stdout
; TyConI dec <- runQ $ reify (mkName "T3")
; runIO $ putStrLn (pprint dec) >> hFlush stdout
; return [] } )
data T11341.T1 (a_0 :: *) where
T11341.MkT1 :: T11341.S1 GHC.Types.Int
data T11341.T2 (a_0 :: *) where
T11341.MkT2 :: T11341.S2 GHC.Types.Char GHC.Types.Int
data T11341.T3 (a_0 :: *) where
T11341.MkT3 :: T11341.Id (T11341.S3 GHC.Types.Char GHC.Types.Int)
{-# LANGUAGE TemplateHaskell, GADTs #-} {-# LANGUAGE TemplateHaskell, GADTs #-}