Commit eeecb864 authored by Jan Stolarek's avatar Jan Stolarek

Add proper GADTs support to Template Haskell

Until now GADTs were supported in Template Haskell by encoding them using
normal data types.  This patch adds proper support for representing GADTs
in TH.

Test Plan: T10828

Reviewers: goldfire, austin, bgamari

Subscribers: thomie, mpickering

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

GHC Trac Issues: #10828
parent a61e717f
This diff is collapsed.
......@@ -35,7 +35,7 @@ import Lexeme
import Util
import FastString
import Outputable
--import TcEvidence
import MonadUtils ( foldrM )
import qualified Data.ByteString as BS
import Control.Monad( unless, liftM, ap )
......@@ -45,7 +45,7 @@ import Control.Applicative (Applicative(..))
import Data.Char ( chr )
import Data.Word ( Word8 )
import Data.Maybe( catMaybes, fromMaybe )
import Data.Maybe( catMaybes, fromMaybe, isNothing )
import Language.Haskell.TH as TH hiding (sigP)
import Language.Haskell.TH.Syntax as TH
......@@ -193,25 +193,38 @@ cvtDec (TySynD tc tvs rhs)
, tcdTyVars = tvs', tcdFVs = placeHolderNames
, tcdRhs = rhs' } }
cvtDec (DataD ctxt tc tvs constrs derivs)
= do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
cvtDec (DataD ctxt tc tvs ksig constrs derivs)
= 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)
(failWith (text "Cannot mix GADT constructors with Haskell 98"
<+> text "constructors"))
; unless (isNothing ksig || isGadtDecl)
(failWith (text "Kind signatures are only allowed on GADTs"))
; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
; ksig' <- cvtKind `traverse` ksig
; cons' <- mapM cvtConstr constrs
; derivs' <- cvtDerivs derivs
; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
, dd_ctxt = ctxt'
, dd_kindSig = Nothing
, dd_kindSig = ksig'
, dd_cons = cons', dd_derivs = derivs' }
; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
, tcdDataDefn = defn
, tcdFVs = placeHolderNames }) }
cvtDec (NewtypeD ctxt tc tvs constr derivs)
cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
= do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
; ksig' <- cvtKind `traverse` ksig
; con' <- cvtConstr constr
; derivs' <- cvtDerivs derivs
; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
, dd_ctxt = ctxt'
, dd_kindSig = Nothing
, dd_kindSig = ksig'
, dd_cons = [con']
, dd_derivs = derivs' }
; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
......@@ -223,7 +236,8 @@ cvtDec (ClassD ctxt cl tvs fds decs)
; fds' <- mapM cvt_fundep fds
; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (ptext (sLit "a class declaration")) decs
; unless (null adts')
(failWith $ (ptext (sLit "Default data instance declarations are not allowed:"))
(failWith $ (text "Default data instance declarations"
<+> text "are not allowed:")
$$ (Outputable.ppr adts'))
; at_defs <- mapM cvt_at_def ats'
; returnJustL $ TyClD $
......@@ -265,13 +279,14 @@ cvtDec (DataFamilyD tc tvs kind)
; returnJustL $ TyClD $ FamDecl $
FamilyDecl DataFamily tc' tvs' result Nothing }
cvtDec (DataInstD ctxt tc tys constrs derivs)
cvtDec (DataInstD ctxt tc tys ksig constrs derivs)
= do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
; ksig' <- cvtKind `traverse` ksig
; cons' <- mapM cvtConstr constrs
; derivs' <- cvtDerivs derivs
; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
, dd_ctxt = ctxt'
, dd_kindSig = Nothing
, dd_kindSig = ksig'
, dd_cons = cons', dd_derivs = derivs' }
; returnJustL $ InstD $ DataFamInstD
......@@ -279,13 +294,14 @@ cvtDec (DataInstD ctxt tc tys constrs derivs)
, dfid_defn = defn
, dfid_fvs = placeHolderNames } }}
cvtDec (NewtypeInstD ctxt tc tys constr derivs)
cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)
= do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
; ksig' <- cvtKind `traverse` ksig
; con' <- cvtConstr constr
; derivs' <- cvtDerivs derivs
; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
, dd_ctxt = ctxt'
, dd_kindSig = Nothing
, dd_kindSig = ksig'
, dd_cons = [con'], dd_derivs = derivs' }
; returnJustL $ InstD $ DataFamInstD
{ dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
......@@ -423,7 +439,6 @@ mkBadDecMsg doc bads
---------------------------------------------------
-- Data types
-- Can't handle GADTs yet
---------------------------------------------------
cvtConstr :: TH.Con -> CvtM (LConDecl RdrName)
......@@ -442,27 +457,51 @@ cvtConstr (RecC c varstrtys)
(RecCon (noLoc args')) }
cvtConstr (InfixC st1 c st2)
= do { c' <- cNameL c
= do { c' <- cNameL c
; cxt' <- returnL []
; st1' <- cvt_arg st1
; st2' <- cvt_arg st2
; returnL $ mkConDeclH98 c' Nothing cxt' (InfixCon st1' st2') }
cvtConstr (ForallC tvs ctxt con)
= do { tvs' <- cvtTvs tvs
= do { tvs' <- cvtTvs tvs
; L loc ctxt' <- cvtContext ctxt
; L _ con' <- cvtConstr con
; let qvars = case (tvs,con_qvars con') of
([],Nothing) -> Nothing
_ ->
Just $ mkHsQTvs (hsQTvExplicit tvs' ++
hsQTvExplicit (fromMaybe (HsQTvs PlaceHolder [])
(con_qvars con')))
; returnL $ con' { con_qvars = qvars
, con_cxt = Just $
L loc (ctxt' ++
unLoc (fromMaybe (noLoc [])
(con_cxt con'))) } }
; L _ con' <- cvtConstr con
; returnL $ case con' of
ConDeclGADT { con_type = conT } ->
con' { con_type =
HsIB PlaceHolder
(noLoc $ HsForAllTy (hsq_explicit tvs') $
(noLoc $ HsQualTy (L loc ctxt') (hsib_body conT))) }
ConDeclH98 {} ->
let qvars = case (tvs, con_qvars con') of
([], Nothing) -> Nothing
(_ , m_qvs ) -> Just $
mkHsQTvs (hsQTvExplicit tvs' ++
maybe [] hsQTvExplicit m_qvs)
in con' { con_qvars = qvars
, con_cxt = Just $
L loc (ctxt' ++
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
; returnL $ mkGadtDecl c' (mkLHsSigType c_ty)}
cvtConstr (RecGadtC c varstrtys ty idx)
= do { c' <- mapM cNameL c
; ty' <- tconNameL 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)
; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) }
cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
cvt_arg (NotStrict, ty) = cvtType ty
......@@ -1159,11 +1198,19 @@ cvtTypeKind ty_str ty
_ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
}
-- | Constructs an application of a type to arguments passed in a list.
mk_apps :: HsType RdrName -> [LHsType RdrName] -> CvtM (LHsType RdrName)
mk_apps head_ty [] = returnL head_ty
mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
; mk_apps (HsAppTy head_ty' ty) tys }
-- | Constructs an arrow type with a specified return type
mk_arr_apps :: [LHsType RdrName] -> HsType RdrName -> CvtM (LHsType RdrName)
mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL
where go :: LHsType RdrName -> HsType RdrName -> CvtM (HsType RdrName)
go arg ret_ty = do { ret_ty_l <- returnL ret_ty
; return (HsFunTy arg ret_ty_l) }
split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
split_ty_app ty = go ty []
where
......
......@@ -89,7 +89,6 @@ import {-# SOURCE #-} HsExpr( LHsExpr, HsExpr, HsSplice, pprExpr, pprSplice )
-- Because Expr imports Decls via HsBracket
import HsBinds
import HsPat
import HsTypes
import HsDoc
import TyCon
......@@ -1078,8 +1077,8 @@ gadtDeclDetails HsIB {hsib_body = lbody_ty} = (details,res_ty,cxt,tvs)
(tvs, cxt, tau) = splitLHsSigmaTy lbody_ty
(details, res_ty) -- See Note [Sorting out the result type]
= case tau of
L _ (HsFunTy (L l (HsRecTy flds)) res_ty)
-> (RecCon (L l flds), res_ty)
L _ (HsFunTy (L l (HsRecTy flds)) res_ty')
-> (RecCon (L l flds), res_ty')
_other -> (PrefixCon [], tau)
hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name]
......
......@@ -17,7 +17,6 @@
module HsPat (
Pat(..), InPat, OutPat, LPat,
HsConDetails(..),
HsConPatDetails, hsConPatArgs,
HsRecFields(..), HsRecField'(..), LHsRecField',
HsRecField, LHsRecField,
......@@ -224,14 +223,6 @@ data Pat id
deriving (Typeable)
deriving instance (DataId id) => Data (Pat id)
-- HsConDetails is use for patterns/expressions *and* for data type declarations
data HsConDetails arg rec
= PrefixCon [arg] -- C p1 p2 p3
| RecCon rec -- C { x = p1, y = p2 }
| InfixCon arg arg -- p1 `C` p2
deriving (Data, Typeable)
type HsConPatDetails id = HsConDetails (LPat id) (HsRecFields id (LPat id))
hsConPatArgs :: HsConPatDetails id -> [LPat id]
......@@ -239,16 +230,8 @@ hsConPatArgs (PrefixCon ps) = ps
hsConPatArgs (RecCon fs) = map (hsRecFieldArg . unLoc) (rec_flds fs)
hsConPatArgs (InfixCon p1 p2) = [p1,p2]
instance (Outputable arg, Outputable rec)
=> Outputable (HsConDetails arg rec) where
ppr (PrefixCon args) = text "PrefixCon" <+> ppr args
ppr (RecCon rec) = text "RecCon:" <+> ppr rec
ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r]
{-
However HsRecFields is used only for patterns and expressions
(not data type declarations)
-}
-- HsRecFields is used only for patterns and expressions (not data type
-- declarations)
data HsRecFields id arg -- A bunch of record fields
-- { x = 3, y = True }
......
......@@ -34,7 +34,9 @@ module HsTypes (
SrcStrictness(..), SrcUnpackedness(..),
getBangType, getBangStrictness,
ConDeclField(..), LConDeclField, pprConDeclFields,
ConDeclField(..), LConDeclField, pprConDeclFields, updateGadtResult,
HsConDetails(..),
FieldOcc(..), LFieldOcc, mkFieldOcc,
AmbiguousFieldOcc(..), mkAmbiguousFieldOcc,
......@@ -47,7 +49,8 @@ module HsTypes (
mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody,
mkEmptyImplicitBndrs, mkEmptyWildCardBndrs,
mkHsQTvs, hsQTvExplicit, isHsKindedTyVar, hsTvbAllKinded,
mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, isEmptyLHsQTvs,
isHsKindedTyVar, hsTvbAllKinded,
hsScopedTvs, hsWcScopedTvs, dropWildCards,
hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames,
hsLTyVarName, hsLTyVarLocName, hsExplicitLTyVarNames,
......@@ -85,6 +88,7 @@ import Maybes( isJust )
import Data.Data hiding ( Fixity )
import Data.Maybe ( fromMaybe )
import Control.Monad ( unless )
#if __GLASGOW_HASKELL > 710
import Data.Semigroup ( Semigroup )
import qualified Data.Semigroup as Semigroup
......@@ -216,6 +220,13 @@ mkHsQTvs tvs = HsQTvs { hsq_implicit = PlaceHolder, hsq_explicit = tvs }
hsQTvExplicit :: LHsQTyVars name -> [LHsTyVarBndr name]
hsQTvExplicit = hsq_explicit
emptyLHsQTvs :: LHsQTyVars Name
emptyLHsQTvs = HsQTvs [] []
isEmptyLHsQTvs :: LHsQTyVars Name -> Bool
isEmptyLHsQTvs (HsQTvs [] []) = True
isEmptyLHsQTvs _ = False
------------------------------------------------
-- HsImplicitBndrs
-- Used to quantify the binders of a type in cases
......@@ -669,6 +680,22 @@ data ConDeclField name -- Record fields have Haddoc docs on them
deriving (Typeable)
deriving instance (DataId name) => Data (ConDeclField name)
instance (OutputableBndr name) => Outputable (ConDeclField name) where
ppr (ConDeclField fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty
-- HsConDetails is used for patterns/expressions *and* for data type
-- declarations
data HsConDetails arg rec
= PrefixCon [arg] -- C p1 p2 p3
| RecCon rec -- C { x = p1, y = p2 }
| InfixCon arg arg -- p1 `C` p2
deriving (Data, Typeable)
instance (Outputable arg, Outputable rec)
=> Outputable (HsConDetails arg rec) where
ppr (PrefixCon args) = text "PrefixCon" <+> ppr args
ppr (RecCon rec) = text "RecCon:" <+> ppr rec
ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r]
type LFieldOcc name = Located (FieldOcc name)
......@@ -735,6 +762,30 @@ unambiguousFieldOcc (Ambiguous rdr sel) = FieldOcc rdr sel
ambiguousFieldOcc :: FieldOcc name -> AmbiguousFieldOcc name
ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel
-- Takes details and result type of a GADT data constructor as created by the
-- parser and rejigs them using information about fixities from the renamer.
-- See Note [Sorting out the result type] in RdrHsSyn
updateGadtResult
:: (Monad m)
=> (SDoc -> m ())
-> SDoc
-> HsConDetails (LHsType Name) (Located [LConDeclField Name])
-- ^ Original details
-> LHsType Name -- ^ Original result type
-> m (HsConDetails (LHsType Name) (Located [LConDeclField Name]),
LHsType Name)
updateGadtResult failWith doc details ty
= do { let (arg_tys, res_ty) = splitHsFunType ty
badConSig = text "Malformed constructor signature"
; case details of
InfixCon {} -> pprPanic "updateGadtResult" (ppr ty)
RecCon {} -> do { unless (null arg_tys)
(failWith (doc <+> badConSig))
; return (details, res_ty) }
PrefixCon {} -> return (PrefixCon arg_tys, res_ty)}
{-
Note [ConDeclField names]
~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -614,7 +614,7 @@ really doesn't matter!
-}
-- | Note [Sorting out the result type]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- In a GADT declaration which is not a record, we put the whole constr type
-- into the res_ty for a ConDeclGADT for now; the renamer will unravel it once
-- it has sorted out operator fixities. Consider for example
......@@ -623,7 +623,7 @@ really doesn't matter!
-- a :*: (b -> (a :*: (b -> (a :+: b))))
--
-- so it's hard to split up the arguments until we've done the precedence
-- resolution (in the renamer) On the other hand, for a record
-- resolution (in the renamer). On the other hand, for a record
-- { x,y :: Int } -> a :*: b
-- there is no doubt. AND we need to sort records out so that
-- we can bring x,y into scope. So:
......
......@@ -76,7 +76,7 @@ templateHaskellNames = [
-- Strict
isStrictName, notStrictName, unpackedName,
-- Con
normalCName, recCName, infixCName, forallCName,
normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName,
-- StrictType
strictTypeName,
-- VarStrictType
......@@ -356,11 +356,13 @@ notStrictName = libFun (fsLit "notStrict") notStrictKey
unpackedName = libFun (fsLit "unpacked") unpackedKey
-- data Con = ...
normalCName, recCName, infixCName, forallCName :: Name
normalCName = libFun (fsLit "normalC") normalCIdKey
recCName = libFun (fsLit "recC") recCIdKey
infixCName = libFun (fsLit "infixC") infixCIdKey
forallCName = libFun (fsLit "forallC") forallCIdKey
normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName :: Name
normalCName = libFun (fsLit "normalC" ) normalCIdKey
recCName = libFun (fsLit "recC" ) recCIdKey
infixCName = libFun (fsLit "infixC" ) infixCIdKey
forallCName = libFun (fsLit "forallC" ) forallCIdKey
gadtCName = libFun (fsLit "gadtC" ) gadtCIdKey
recGadtCName = libFun (fsLit "recGadtC") recGadtCIdKey
-- type StrictType = ...
strictTypeName :: Name
......@@ -801,19 +803,22 @@ notStrictKey = mkPreludeMiscIdUnique 364
unpackedKey = mkPreludeMiscIdUnique 365
-- data Con = ...
normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique
normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey, gadtCIdKey,
recGadtCIdKey :: Unique
normalCIdKey = mkPreludeMiscIdUnique 370
recCIdKey = mkPreludeMiscIdUnique 371
infixCIdKey = mkPreludeMiscIdUnique 372
forallCIdKey = mkPreludeMiscIdUnique 373
gadtCIdKey = mkPreludeMiscIdUnique 374
recGadtCIdKey = mkPreludeMiscIdUnique 375
-- type StrictType = ...
strictTKey :: Unique
strictTKey = mkPreludeMiscIdUnique 374
strictTKey = mkPreludeMiscIdUnique 376
-- type VarStrictType = ...
varStrictTKey :: Unique
varStrictTKey = mkPreludeMiscIdUnique 375
varStrictTKey = mkPreludeMiscIdUnique 377
-- data Type = ...
forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey,
......
......@@ -615,11 +615,10 @@ getLocalNonValBinders fixity_env
mk_fld_env :: HsDataDefn RdrName -> [Name] -> [FieldLabel] -> [(Name, [FieldLabel])]
mk_fld_env d names flds = concatMap find_con_flds (dd_cons d)
where
find_con_flds (L _ (ConDeclH98 { con_name = rdrs
, con_details = RecCon cdflds }))
= map (\ (L _ rdr) -> ( find_con_name rdr
, concatMap find_con_decl_flds (unLoc cdflds)))
[rdrs] -- AZ:TODO remove map
find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr
, con_details = RecCon cdflds }))
= [( find_con_name rdr
, concatMap find_con_decl_flds (unLoc cdflds) )]
find_con_flds (L _ (ConDeclGADT
{ con_names = rdrs
, con_type = (HsIB { hsib_body = res_ty})}))
......@@ -630,6 +629,7 @@ getLocalNonValBinders fixity_env
(_tvs, _cxt, tau) = splitLHsSigmaTy res_ty
cdflds = case tau of
L _ (HsFunTy (L _ (HsAppsTy [HsAppPrefix (L _ (HsRecTy flds))])) _) -> flds
L _ (HsFunTy (L _ (HsRecTy flds)) _) -> flds
_ -> []
find_con_flds _ = []
......
......@@ -469,10 +469,7 @@ rnHsTyKi _ doc (HsBangTy b ty)
; return (HsBangTy b ty', fvs) }
rnHsTyKi _ doc@(ConDeclCtx names) (HsRecTy flds)
= do {
-- AZ:reviewers: is there a monadic version of concatMap?
flss <- mapM (lookupConstructorFields . unLoc) names
; let fls = concat flss
= do { fls <- concatMapM (lookupConstructorFields . unLoc) names
; (flds', fvs) <- rnConDeclFields fls doc flds
; return (HsRecTy flds', fvs) }
......
......@@ -1312,43 +1312,87 @@ reifyTyCon tc
| otherwise
= do { cxt <- reifyCxt (tyConStupidTheta tc)
; let tvs = tyConTyVars tc
; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
; let tvs = tyConTyVars tc
dataCons = tyConDataCons tc
-- see Note [Reifying GADT data constructors]
isGadt = any (not . null . dataConEqSpec) dataCons
; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons
; r_tvs <- reifyTyVars tvs (Just tc)
; let name = reifyName tc
deriv = [] -- Don't know about deriving
decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
| otherwise = TH.DataD cxt name r_tvs cons deriv
decl | isNewTyCon tc =
TH.NewtypeD cxt name r_tvs Nothing (head cons) deriv
| otherwise =
TH.DataD cxt name r_tvs Nothing cons deriv
; return (TH.TyConI decl) }
reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
-- For GADTs etc, see Note [Reifying data constructors]
reifyDataCon tys dc
= do { let (ex_tvs, theta, arg_tys) = dataConInstSig dc tys
stricts = map reifyStrict (dataConSrcBangs dc)
fields = dataConFieldLabels dc
name = reifyName dc
; r_arg_tys <- reifyTypes arg_tys
; let main_con | not (null fields)
= TH.RecC name
(zip3 (map reifyFieldLabel fields) stricts r_arg_tys)
reifyDataCon :: Bool -> [Type] -> DataCon -> TcM TH.Con
-- For GADTs etc, see Note [Reifying GADT data constructors]
reifyDataCon isGadtDataCon tys dc
= do { let -- used for H98 data constructors
(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, _)
= dataConFullSig dc
stricts = map reifyStrict (dataConSrcBangs dc)
fields = dataConFieldLabels dc
name = reifyName dc
r_ty_name = reifyName (dataConTyCon dc) -- return type for GADTs
-- return type indices
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)
stricts r_arg_tys)
| not (null fields)
= TH.RecGadtC [name]
(zip3 (map (reifyName . flSelector) fields)
stricts 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] (stricts `zip` r_arg_tys) r_ty_name
idx_tys
| otherwise
= TH.NormalC name (stricts `zip` r_arg_tys)
[r_a1, r_a2] = r_arg_tys
[s1, s2] = stricts
(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
| otherwise = do
{ cxt <- reifyCxt theta'
; ex_tvs'' <- reifyTyVars ex_tvs' Nothing
; return (TH.ForallC ex_tvs'' cxt main_con) }
; ASSERT( length arg_tys == length stricts )
if null ex_tvs && null theta then
return main_con
else do
{ cxt <- reifyCxt theta
; ex_tvs' <- reifyTyVars ex_tvs Nothing
; return (TH.ForallC ex_tvs' cxt main_con) } }
ret_con }
-- Note [Reifying GADT data constructors]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- At this point in the compilation pipeline we have no way of telling whether a
-- data type was declared as a H98 data type or as a GADT. We have to rely on
-- heuristics here. We look at dcEqSpec field of all data constructors in a
-- data type declaration. If at least one data constructor has non-empty
-- dcEqSpec this means that the data type must have been declared as a GADT.
-- Consider these declarations:
--
-- data T a where
-- MkT :: forall a. (a ~ Int) => T a
--
-- data T a where
-- MkT :: T Int
--
-- First declaration will be reified as a GADT. Second declaration will be
-- reified as a normal H98 data type declaration.
------------------------------
reifyClass :: Class -> TcM TH.Info
......@@ -1483,13 +1527,18 @@ reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor
(_rep_tc, rep_tc_args) = splitTyConApp rhs
etad_tyvars = dropList rep_tc_args tvs
eta_expanded_lhs = lhs `chkAppend` mkTyVarTys etad_tyvars
; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons rep_tc)
dataCons = tyConDataCons rep_tc
-- see Note [Reifying GADT data constructors]
isGadt = any (not . null . dataConEqSpec) dataCons
; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons
; let types_only = filterOutInvisibleTypes fam_tc eta_expanded_lhs
; th_tys <- reifyTypes types_only
; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys
; return (if isNewTyCon rep_tc
then TH.NewtypeInstD [] fam' annot_th_tys (head cons) []
else TH.DataInstD [] fam' annot_th_tys cons []) }
; return $
if isNewTyCon rep_tc
then TH.NewtypeInstD [] fam' annot_th_tys Nothing (head cons) []
else TH.DataInstD [] fam' annot_th_tys Nothing cons []
}
where
fam_tc = famInstTyCon inst
......@@ -1772,21 +1821,6 @@ ppr_th :: TH.Ppr a => a -> SDoc
ppr_th x = text (TH.pprint x)
{-
Note [Reifying data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Template Haskell syntax is rich enough to express even GADTs,
provided we do so in the equality-predicate form. So a GADT
like
data T a where
MkT1 :: a -> T [a]
MkT2 :: T Int
will appear in TH syntax like this
data T a = forall b. (a ~ [b]) => MkT1 b
| (a ~ Int) => MkT2
Note [Reifying field labels]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When reifying a datatype declared with DuplicateRecordFields enabled, we want
......
......@@ -1482,7 +1482,8 @@ tcGadtSigType :: SDoc -> Name -> LHsSigType Name
(Located [LConDeclField Name]) )
tcGadtSigType doc name ty@(HsIB { hsib_vars = vars })
= do { let (hs_details', res_ty', cxt, gtvs) = gadtDeclDetails ty
; (hs_details, res_ty) <- tcUpdateConResult doc hs_details' res_ty'
; (hs_details, res_ty) <-
updateGadtResult failWithTc doc hs_details' res_ty'
; (_, (ctxt, arg_tys, res_ty, field_lbls, stricts))
<- solveEqualities $
tcImplicitTKBndrs vars $
......@@ -1500,35 +1501,6 @@ tcGadtSigType doc name ty@(HsIB { hsib_vars = vars })
; return (ctxt,stricts,field_lbls,arg_tys,res_ty,hs_details)
}
tcUpdateConResult :: SDoc
-> HsConDetails (LHsType Name) (Located [LConDeclField Name])
-- Original details
-> LHsType Name -- The original result type
-> TcM (HsConDetails (LHsType Name) (Located [LConDeclField Name]),
LHsType Name)
tcUpdateConResult doc details ty
= do { let (arg_tys, res_ty) = splitHsFunType ty
-- We can finally split it up,
-- now the renamer has dealt with fixities
-- See Note [Sorting out the result type] in RdrHsSyn
; case details of
InfixCon {} -> pprPanic "tcUpdateConResult" (ppr ty)
-- See Note [Sorting out the result type] in RdrHsSyn
RecCon {} -> do { unless (null arg_tys)
(failWithTc (badRecResTy doc))
-- AZ: This error used to be reported during
-- renaming, will now be reported in type
-- checking. Is this a problem?
; return (details, res_ty) }
PrefixCon {} -> return (PrefixCon arg_tys, res_ty)}
where
badRecResTy :: SDoc -> SDoc
badRecResTy ctxt = ctxt <+>
ptext (sLit "Malformed constructor signature")
tcConIsInfixH98 :: Name
-> HsConDetails (LHsType Name) (Located [LConDeclField Name])
-> TcM Bool
......
......@@ -284,6 +284,11 @@ Template Haskell
have also been introduced, serving the same functions as their
pattern and expression counterparts.
- ``Template Haskell`` has now explicit support for representing GADTs. Until
now GADTs were encoded using ``NormalC``, ``RecC`` (record syntax) and
``ForallC`` constructors. Two new constructors - ``GadtC`` and ``RecGadtC`` -
are now supported during quoting, splicing and reification.
- Primitive chars (e.g., ``[| 'a'# |]``) and primitive strings (e.g.,
``[| "abc"# |]``) can now be quoted with Template Haskell. The
``Lit`` data type also has a new constructor, ``CharPrimL``, for
......