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]
= do arg_tys <- repList bangTypeQTyConName repBangTy ps
rep2 normalCName [unC con, unC arg_tys]
repConstr (PrefixCon ps) (Just res_ty) cons
= do arg_tys <- repList bangTypeQTyConName repBangTy ps
(res_n, idx) <- repGadtReturnTy res_ty
rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_n
, unC idx]
repConstr (PrefixCon ps) (Just (L _ res_ty)) cons
= do arg_tys <- repList bangTypeQTyConName repBangTy ps
res_ty' <- repTy res_ty
rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty']
repConstr (RecCon (L _ ips)) resTy cons
= do args <- concatMapM rep_ip ips
arg_vtys <- coreList varBangTypeQTyConName args
case resTy of
Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]
Just res_ty -> do
(res_n, idx) <- repGadtReturnTy res_ty
Just (L _ res_ty) -> do
res_ty' <- repTy res_ty
rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys,
unC res_n, unC idx]
unC res_ty']
where
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]
repConstr (InfixCon {}) (Just _) _ = panic "repConstr: infix GADT constructor?"
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 -------------------
repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ
......
......@@ -189,10 +189,10 @@ cvtDec (TySynD tc tvs rhs)
, tcdRhs = rhs' } }
cvtDec (DataD ctxt tc tvs ksig constrs derivs)
= do { let isGadtCon (GadtC _ _ _ _) = True
isGadtCon (RecGadtC _ _ _ _) = True
isGadtCon (ForallC _ _ c ) = isGadtCon c
isGadtCon _ = False
= do { let isGadtCon (GadtC _ _ _) = True
isGadtCon (RecGadtC _ _ _) = True
isGadtCon (ForallC _ _ c) = isGadtCon c
isGadtCon _ = False
isGadtDecl = all isGadtCon constrs
isH98Decl = all (not . isGadtCon) constrs
; unless (isGadtDecl || isH98Decl)
......@@ -480,22 +480,18 @@ cvtConstr (ForallC tvs ctxt con)
unLoc (fromMaybe (noLoc [])
(con_cxt con'))) } }
cvtConstr (GadtC c strtys ty idx)
= do { c' <- mapM cNameL c
; args <- mapM cvt_arg strtys
; idx' <- mapM cvtType idx
; ty' <- tconNameL ty
; L _ ret_ty <- mk_apps (HsTyVar ty') idx'
; c_ty <- mk_arr_apps args ret_ty
cvtConstr (GadtC c strtys ty)
= do { c' <- mapM cNameL c
; args <- mapM cvt_arg strtys
; L _ ty' <- cvtType ty
; c_ty <- mk_arr_apps args ty'
; returnL $ mkGadtDecl c' (mkLHsSigType c_ty)}
cvtConstr (RecGadtC c varstrtys ty idx)
cvtConstr (RecGadtC c varstrtys ty)
= do { c' <- mapM cNameL c
; ty' <- tconNameL ty
; ty' <- cvtType ty
; rec_flds <- mapM cvt_id_arg varstrtys
; idx' <- mapM cvtType idx
; ret_ty <- mk_apps (HsTyVar ty') idx'
; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ret_ty)
; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty')
; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) }
cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
......
......@@ -13,6 +13,7 @@ TcSplice: Template Haskell splices
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE MultiWayIf #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module TcSplice(
......@@ -1338,41 +1339,42 @@ reifyDataCon isGadtDataCon tys dc
(ex_tvs, theta, arg_tys)
= dataConInstSig dc tys
-- 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
(srcUnpks, srcStricts)
= mapAndUnzip reifySourceBang (dataConSrcBangs dc)
dcdBangs = zipWith TH.Bang srcUnpks srcStricts
fields = dataConFieldLabels dc
name = reifyName dc
r_ty_name = reifyName (dataConTyCon dc) -- return type for GADTs
-- return type indices
-- Universal tvs present in eq_spec need to be filtered out, as
-- they will not appear anywhere in the type.
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
; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys)
; idx_tys <- reifyTypes idx
; 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
; let [r_a1, r_a2] = r_arg_tys
[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 )
| otherwise = ( ex_tvs, theta )
ret_con | null ex_tvs' && null theta' = return main_con
......
......@@ -11,7 +11,7 @@ module Language.Haskell.TH.Lib where
import Language.Haskell.TH.Syntax hiding (Role, InjectivityAnn)
import qualified Language.Haskell.TH.Syntax as TH
import Control.Monad( liftM, liftM2, liftM3 )
import Control.Monad( liftM, liftM2 )
import Data.Word( Word8 )
----------------------------------------------------------
......@@ -550,13 +550,11 @@ infixC st1 con st2 = do st1' <- st1
forallC :: [TyVarBndr] -> CxtQ -> ConQ -> ConQ
forallC ns ctxt con = liftM2 (ForallC ns) ctxt con
gadtC :: [Name] -> [StrictTypeQ] -> Name -> [TypeQ] -> ConQ
gadtC cons strtys ty idx = liftM3 (GadtC cons) (sequence strtys)
(return ty) (sequence idx)
gadtC :: [Name] -> [StrictTypeQ] -> TypeQ -> ConQ
gadtC cons strtys ty = liftM2 (GadtC cons) (sequence strtys) ty
recGadtC :: [Name] -> [VarStrictTypeQ] -> Name -> [TypeQ] -> ConQ
recGadtC cons varstrtys ty idx = liftM3 (RecGadtC cons) (sequence varstrtys)
(return ty) (sequence idx)
recGadtC :: [Name] -> [VarStrictTypeQ] -> TypeQ -> ConQ
recGadtC cons varstrtys ty = liftM2 (RecGadtC cons) (sequence varstrtys) ty
-------------------------------------------------------------------------------
-- * Type
......
......@@ -361,10 +361,10 @@ ppr_data maybeInst ctxt t argsDoc ksig cs decs
isGadtDecl :: Bool
isGadtDecl = not (null cs) && all isGadtCon cs
where isGadtCon (GadtC _ _ _ _ ) = True
isGadtCon (RecGadtC _ _ _ _) = True
isGadtCon (ForallC _ _ x ) = isGadtCon x
isGadtCon _ = False
where isGadtCon (GadtC _ _ _ ) = True
isGadtCon (RecGadtC _ _ _) = True
isGadtCon (ForallC _ _ x ) = isGadtCon x
isGadtCon _ = False
ksigDoc = case ksig of
Nothing -> empty
......@@ -506,38 +506,38 @@ instance Ppr Con where
<+> pprName' Infix c
<+> pprBangType st2
ppr (ForallC ns ctxt (GadtC c sts ty idx))
= commaSep c <+> dcolon <+> pprForall ns ctxt <+> pprGadtRHS sts ty idx
ppr (ForallC ns ctxt (GadtC c sts ty))
= 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
<+> pprRecFields vsts ty idx
<+> pprRecFields vsts ty
ppr (ForallC ns ctxt con)
= pprForall ns ctxt <+> ppr con
ppr (GadtC c sts ty idx)
= commaSep c <+> dcolon <+> pprGadtRHS sts ty idx
ppr (GadtC c sts ty)
= commaSep c <+> dcolon <+> pprGadtRHS sts ty
ppr (RecGadtC c vsts ty idx)
= commaSep c <+> dcolon <+> pprRecFields vsts ty idx
ppr (RecGadtC c vsts ty)
= commaSep c <+> dcolon <+> pprRecFields vsts ty
pprForall :: [TyVarBndr] -> Cxt -> Doc
pprForall ns ctxt
= text "forall" <+> hsep (map ppr ns)
<+> char '.' <+> pprCxt ctxt
pprRecFields :: [(Name, Strict, Type)] -> Name -> [Type] -> Doc
pprRecFields vsts ty idx
pprRecFields :: [(Name, Strict, Type)] -> Type -> Doc
pprRecFields vsts ty
= braces (sep (punctuate comma $ map pprVarBangType vsts))
<+> arrow <+> ppr ty <+> sep (map ppr idx)
<+> arrow <+> ppr ty
pprGadtRHS :: [(Strict, Type)] -> Name -> [Type] -> Doc
pprGadtRHS [] ty idx
= ppr ty <+> sep (map ppr idx)
pprGadtRHS sts ty idx
pprGadtRHS :: [(Strict, Type)] -> Type -> Doc
pprGadtRHS [] ty
= ppr ty
pprGadtRHS sts ty
= sep (punctuate (space <> arrow) (map pprBangType sts))
<+> arrow <+> ppr ty <+> sep (map ppr idx)
<+> arrow <+> ppr ty
------------------------------
pprVarBangType :: VarBangType -> Doc
......@@ -615,6 +615,9 @@ pprParendType WildCardT = char '_'
pprParendType (InfixT x n y) = parens (ppr x <+> pprName' Infix n <+> ppr y)
pprParendType t@(UInfixT {}) = parens (pprUInfixT t)
pprParendType (ParensT t) = ppr t
pprParendType tuple | (TupleT n, args) <- split tuple
, length args == n
= parens (commaSep args)
pprParendType other = parens (ppr other)
pprUInfixT :: Type -> Doc
......
......@@ -1632,25 +1632,40 @@ data Con = NormalC Name [BangType] -- ^ @C Int a@
| InfixC BangType Name BangType -- ^ @Int :+ a@
| ForallC [TyVarBndr] Cxt Con -- ^ @forall a. Eq a => C [a]@
| GadtC [Name] [BangType]
Name -- See Note [GADT return type]
[Type] -- Indices of the type constructor
Type -- See Note [GADT return type]
-- ^ @C :: a -> b -> T b Int@
| RecGadtC [Name] [VarBangType]
Name -- See Note [GADT return type]
[Type] -- Indices of the type constructor
Type -- See Note [GADT return type]
-- ^ @C :: { v :: Int } -> T b Int@
deriving (Show, Eq, Ord, Data, Typeable, Generic)
-- Note [GADT return type]
-- ~~~~~~~~~~~~~~~~~~~~~~~
--
-- The name of the return type stored by a GADT constructor does not necessarily
-- match the name of the data type:
-- The return type of a GADT constructor does not necessarily match the name of
-- the data type:
--
-- type S = T
--
-- data T a where
-- 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
-- ^ @C { {\-\# UNPACK \#-\} !}a@
......
......@@ -40,8 +40,8 @@ $( return
, VarT (mkName "a")
)
]
( mkName "T" )
[ VarT (mkName "a") ]
(AppT (ConT (mkName "T"))
(VarT (mkName "a")))
, ForallC [PlainTV (mkName "a"), PlainTV (mkName "b")]
[AppT (AppT EqualityT (VarT $ mkName "a" ) )
(ConT $ mkName "Int") ] $
......@@ -55,8 +55,8 @@ $( return
, VarT (mkName "b")
)
]
( mkName "T" )
[ ConT (mkName "Int") ] ]
(AppT (ConT (mkName "T"))
(ConT (mkName "Int"))) ]
[] ])
$( do { -- test reification
......
......@@ -15,86 +15,3 @@ data T'_0 a_1 :: * where
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,
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
, VarT (mkName "b")
)
]
( mkName "T" )
[ ConT (mkName "Int") ]
(AppT (ConT (mkName "T"))
(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 #-}
module T4188 where
import Language.Haskell.TH
import System.IO
class C a where {}
data T1 a where
MkT1 :: a -> b -> T1 a
data T2 a where
MkT2 :: (C a, C b) => a -> b -> T2 a
data T3 x where
MkT3 :: (C x, C y) => x -> y -> T3 (x,y)
$(do { dec1 <- reify ''T1
; runIO (putStrLn (pprint dec1))
; dec2 <- reify ''T2
; runIO (putStrLn (pprint dec2))
; dec3 <- reify ''T3
; runIO (putStrLn (pprint dec3))
; runIO (hFlush stdout)
; return [] })
{-# LANGUAGE TemplateHaskell, GADTs #-}
module T4188 where
import Language.Haskell.TH
import System.IO
class C a where {}
data T1 a where
MkT1 :: a -> b -> T1 a
data T2 a where
MkT2 :: (C a, C b) => a -> b -> T2 a
data T3 x where
MkT3 :: (C x, C y) => x -> y -> T3 (x,y)
$(do { dec1 <- reify ''T1
; runIO (putStrLn (pprint dec1))
; dec2 <- reify ''T2
; runIO (putStrLn (pprint dec2))
; dec3 <- reify ''T3
; runIO (putStrLn (pprint dec3))
; runIO (hFlush stdout)
; return [] })
......@@ -3,7 +3,7 @@ TH_RichKinds2.hs:24:4: Warning:
data SMaybe_0 :: (k_0 -> *) -> GHC.Base.Maybe k_0 -> * where
SNothing_2 :: forall s_3 . SMaybe_0 s_3 'GHC.Base.Nothing
SJust_4 :: forall s_5 a_6 . (s_5 a_6) -> SMaybe_0 s_5
'GHC.Base.Just a_6
('GHC.Base.Just a_6)
type instance TH_RichKinds2.Map f_7 '[] = '[]
type instance TH_RichKinds2.Map f_8
('GHC.Types.: h_9 t_10) = 'GHC.Types.: (f_8 h_9)
......
......@@ -381,11 +381,7 @@ test('T10796a', normal, compile, ['-v0'])
test('T10796b', normal, compile_fail, ['-v0'])
test('T10811', normal, compile, ['-v0'])
test('T10810', normal, compile, ['-v0'])
test('T10828', normalise_version('array', 'base', 'binary', 'bytestring',
'containers', 'deepseq', 'ghc-boot',
'ghc-prim', 'integer-gmp', 'pretty',
'template-haskell'
), compile, ['-v0 -ddump-tc -dsuppress-uniques'])
test('T10828', normal, compile, ['-v0 -dsuppress-uniques'])
test('T10828a', normal, compile_fail, ['-v0'])
test('T10828b', normal, compile_fail, ['-v0'])
test('T10891', normal, compile, ['-v0'])
......@@ -397,5 +393,6 @@ test('T10819',
multimod_compile,
['T10819.hs', '-v0 ' + config.ghc_th_way_flags])
test('T10820', normal, compile_and_run, ['-v0'])
test('T11341', normal, compile, ['-v0 -dsuppress-uniques'])
test('TH_finalizer', normal, compile, ['-v0'])
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