diff options
49 files changed, 831 insertions, 472 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 30eb388137..0c72a9f266 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -252,9 +252,8 @@ repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs })) repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; tc_tvs <- mk_extra_tvs tc tvs defn - ; dec <- addTyClTyVarBinds tc_tvs $ \bndrs -> - repDataDefn tc1 bndrs Nothing (map hsLTyVarName $ hsQTvExplicit tc_tvs) defn + ; dec <- addTyClTyVarBinds tvs $ \bndrs -> + repDataDefn tc1 bndrs Nothing defn ; return (Just (loc, dec)) } repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, @@ -287,25 +286,27 @@ repRoleD (L loc (RoleAnnotDecl tycon roles)) ------------------------- repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr] -> Maybe (Core [TH.TypeQ]) - -> [Name] -> HsDataDefn Name + -> HsDataDefn Name -> DsM (Core TH.DecQ) -repDataDefn tc bndrs opt_tys tv_names - (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt +repDataDefn tc bndrs opt_tys + (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig , dd_cons = cons, dd_derivs = mb_derivs }) = do { cxt1 <- repLContext cxt ; derivs1 <- repDerivs mb_derivs - ; case new_or_data of - NewType -> do { con1 <- repC tv_names (head cons) - ; case con1 of - [c] -> repNewtype cxt1 tc bndrs opt_tys c derivs1 - _cs -> failWithDs (ptext - (sLit "Multiple constructors for newtype:") - <+> pprQuotedList - (getConNames $ unLoc $ head cons)) - } - DataType -> do { consL <- concatMapM (repC tv_names) cons - ; cons1 <- coreList conQTyConName consL - ; repData cxt1 tc bndrs opt_tys cons1 derivs1 } } + ; case (new_or_data, cons) of + (NewType, [con]) -> do { con' <- repC con + ; ksig' <- repMaybeLKind ksig + ; repNewtype cxt1 tc bndrs opt_tys ksig' con' + derivs1 } + (NewType, _) -> failWithDs (text "Multiple constructors for newtype:" + <+> pprQuotedList + (getConNames $ unLoc $ head cons)) + (DataType, _) -> do { ksig' <- repMaybeLKind ksig + ; consL <- mapM repC cons + ; cons1 <- coreList conQTyConName consL + ; repData cxt1 tc bndrs opt_tys ksig' cons1 + derivs1 } + } repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr] -> LHsType Name @@ -399,34 +400,6 @@ repAssocTyFamDefaults = mapM rep_deflt ; repTySynInst tc1 eqn1 } ------------------------- -mk_extra_tvs :: Located Name -> LHsQTyVars Name - -> HsDataDefn Name -> DsM (LHsQTyVars Name) --- If there is a kind signature it must be of form --- k1 -> .. -> kn -> * --- Return type variables [tv1:k1, tv2:k2, .., tvn:kn] -mk_extra_tvs tc tvs defn - | HsDataDefn { dd_kindSig = Just hs_kind } <- defn - = do { extra_tvs <- go hs_kind - ; return (tvs { hsq_explicit = hsq_explicit tvs ++ extra_tvs }) } - | otherwise - = return tvs - where - go :: LHsKind Name -> DsM [LHsTyVarBndr Name] - go (L loc (HsFunTy kind rest)) - = do { uniq <- newUnique - ; let { occ = mkTyVarOccFS (fsLit "t") - ; nm = mkInternalName uniq occ loc - ; hs_tv = L loc (KindedTyVar (noLoc nm) kind) } - ; hs_tvs <- go rest - ; return (hs_tv : hs_tvs) } - - go (L _ (HsTyVar (L _ n))) - | isLiftedTypeKindTyConName n - = return [] - - go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc) - -------------------------- -- represent fundeps -- repLFunDeps :: [Located (FunDep (Located Name))] -> DsM (Core [TH.FunDep]) @@ -514,7 +487,7 @@ repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name , hsq_explicit = [] } -- Yuk ; addTyClTyVarBinds hs_tvs $ \ bndrs -> do { tys1 <- repList typeQTyConName repLTy tys - ; repDataDefn tc bndrs (Just tys1) var_names defn } } + ; repDataDefn tc bndrs (Just tys1) defn } } repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ) repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ @@ -620,131 +593,49 @@ repAnnProv ModuleAnnProvenance -- Constructors ------------------------------------------------------- -repC :: [Name] -> LConDecl Name -> DsM [Core TH.ConQ] -repC _ (L _ (ConDeclH98 { con_name = con - , con_qvars = Nothing, con_cxt = Nothing - , con_details = details })) - = do { con1 <- lookupLOcc con - -- See Note [Binders and occurrences] - ; mapM (\c -> repConstr c details) [con1] } - -repC _ (L _ (ConDeclH98 { con_name = con - , con_qvars = mcon_tvs, con_cxt = mcxt - , con_details = details })) - = do { let (eq_ctxt, con_tv_subst) = ([], []) - ; let con_tvs = fromMaybe (HsQTvs [] []) mcon_tvs - ; let ctxt = unLoc $ fromMaybe (noLoc []) mcxt - ; let ex_tvs = HsQTvs { hsq_implicit = filterOut (in_subst con_tv_subst) (hsq_implicit con_tvs) - , hsq_explicit = filterOut (in_subst con_tv_subst . hsLTyVarName) (hsq_explicit con_tvs) } - - ; let binds = [] - ; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs - addTyVarBinds ex_tvs $ \ ex_bndrs -> -- Binds the remaining con_tvs - do { con1 <- lookupLOcc con -- See Note [Binders and occurrences] - ; c' <- repConstr con1 details - ; ctxt' <- repContext (eq_ctxt ++ ctxt) - ; if (null (hsq_implicit ex_tvs) && null (hsq_explicit ex_tvs) - && null (eq_ctxt ++ ctxt)) - then return c' - else rep2 forallCName ([unC ex_bndrs, unC ctxt'] ++ [unC c']) } - ; return [b] - } -repC tvs (L _ (ConDeclGADT { con_names = cons - , con_type = res_ty@(HsIB { hsib_vars = con_vars })})) - = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty - ; let ex_tvs - = HsQTvs { hsq_implicit = [] - , hsq_explicit = map (noLoc . UserTyVar . noLoc) $ - filterOut - (in_subst con_tv_subst) - con_vars } - - ; binds <- mapM dupBinder con_tv_subst - ; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs - addTyVarBinds ex_tvs $ \ ex_bndrs -> -- Binds the remaining con_tvs - do { cons1 <- mapM lookupLOcc cons -- See Note [Binders and occurrences] - ; let (details,res_ty',_,_) = gadtDeclDetails res_ty - ; let doc = ptext (sLit "In the constructor for ") <+> ppr (head cons) - ; (hs_details,_res_ty) <- update_con_result doc details res_ty' - ; c' <- mapM (\c -> repConstr c hs_details) cons1 - ; ctxt' <- repContext eq_ctxt - ; rep2 forallCName ([unC ex_bndrs, unC ctxt'] ++ (map unC c')) } - ; return [b] - } - -in_subst :: [(Name,Name)] -> Name -> Bool -in_subst [] _ = False -in_subst ((n',_):ns) n = n==n' || in_subst ns n - -update_con_result :: SDoc - -> HsConDetails (LHsType Name) (Located [LConDeclField Name]) - -- Original details - -> LHsType Name -- The original result type - -> DsM (HsConDetails (LHsType Name) (Located [LConDeclField Name]), - LHsType Name) -update_con_result 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 "update_con_result" (ppr ty) - -- See Note [Sorting out the result type] in RdrHsSyn - - RecCon {} -> do { unless (null arg_tys) - (failWithDs (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") - -mkGadtCtxt :: [Name] -- Tyvars of the data type - -> LHsSigType Name - -> DsM (HsContext Name, [(Name,Name)]) --- Given a data type in GADT syntax, figure out the equality --- context, so that we can represent it with an explicit --- equality context, because that is the only way to express --- the GADT in TH syntax --- --- Example: --- data T a b c where { MkT :: forall d e. d -> e -> T d [e] e --- mkGadtCtxt [a,b,c] [d,e] (T d [e] e) --- returns --- (b~[e], c~e), [d->a] --- --- This function is fiddly, but not really hard -mkGadtCtxt data_tvs res_ty - | Just (_, tys) <- hsTyGetAppHead_maybe ty - , data_tvs `equalLength` tys - = return (go [] [] (data_tvs `zip` tys)) +repC :: LConDecl Name -> DsM (Core TH.ConQ) +repC (L _ (ConDeclH98 { con_name = con + , con_qvars = Nothing, con_cxt = Nothing + , con_details = details })) + = repDataCon con details + +repC (L _ (ConDeclH98 { con_name = con + , con_qvars = mcon_tvs, con_cxt = mcxt + , con_details = details })) + = do { let con_tvs = fromMaybe emptyLHsQTvs mcon_tvs + ctxt = unLoc $ fromMaybe (noLoc []) mcxt + ; addTyVarBinds con_tvs $ \ ex_bndrs -> + do { c' <- repDataCon con details + ; ctxt' <- repContext ctxt + ; if isEmptyLHsQTvs con_tvs && null ctxt + then return c' + else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) + } + } - | otherwise - = failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty) +repC (L _ (ConDeclGADT { con_names = cons + , con_type = res_ty@(HsIB { hsib_vars = con_vars })})) + | (details, res_ty', L _ [] , []) <- gadtDetails + , [] <- con_vars + -- no implicit or explicit variables, no context = no need for a forall + = do { let doc = text "In the constructor for " <+> ppr (head cons) + ; (hs_details, gadt_res_ty) <- + updateGadtResult failWithDs doc details res_ty' + ; repGadtDataCons cons hs_details gadt_res_ty } + + | (details,res_ty',ctxt, tvs) <- gadtDetails + = do { let doc = text "In the constructor for " <+> ppr (head cons) + con_tvs = HsQTvs { hsq_implicit = [] + , hsq_explicit = (map (noLoc . UserTyVar . noLoc) + con_vars) ++ tvs } + ; addTyVarBinds con_tvs $ \ ex_bndrs -> do + { (hs_details, gadt_res_ty) <- + updateGadtResult failWithDs doc details res_ty' + ; c' <- repGadtDataCons cons hs_details gadt_res_ty + ; ctxt' <- repContext (unLoc ctxt) + ; rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } } where - (_,ty',_,_) = gadtDeclDetails res_ty - (_arg_tys,ty) = splitHsFunType ty' - go cxt subst [] = (cxt, subst) - go cxt subst ((data_tv, ty) : rest) - | Just con_tv <- is_hs_tyvar ty - , isTyVarName con_tv - , not (in_subst subst con_tv) - = go cxt ((con_tv, data_tv) : subst) rest - | otherwise - = go (eq_pred : cxt) subst rest - where - loc = getLoc ty - eq_pred = L loc (HsEqTy (L loc (HsTyVar (L loc data_tv))) ty) - - is_hs_tyvar (L _ (HsTyVar (L _ n))) = Just n -- Type variables *and* tycons - is_hs_tyvar (L _ (HsParTy ty)) = is_hs_tyvar ty - is_hs_tyvar _ = Nothing + gadtDetails = gadtDeclDetails res_ty repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ)) repBangTy ty = do @@ -766,8 +657,8 @@ repBangTy ty = do repDerivs :: HsDeriving Name -> DsM (Core TH.CxtQ) repDerivs deriv = do let clauses - | Nothing <- deriv = [] | Just (L _ ctxt) <- deriv = ctxt + | otherwise = [] tys <- repList typeQTyConName (rep_deriv . hsSigType) clauses @@ -903,12 +794,13 @@ addTyVarBinds :: LHsQTyVars Name -- the binders to be -- the computations passed as the second argument is executed in that extended -- meta environment and gets the *new* names on Core-level as an argument -addTyVarBinds (HsQTvs { hsq_implicit = kvs, hsq_explicit = tvs }) m - = do { fresh_kv_names <- mkGenSyms kvs - ; fresh_tv_names <- mkGenSyms (map hsLTyVarName tvs) - ; let fresh_names = fresh_kv_names ++ fresh_tv_names +addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs }) m + = do { fresh_imp_names <- mkGenSyms imp_tvs + ; fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs) + ; let fresh_names = fresh_imp_names ++ fresh_exp_names ; term <- addBinds fresh_names $ - do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (tvs `zip` fresh_tv_names) + do { kbs <- repList tyVarBndrTyConName mk_tv_bndr + (exp_tvs `zip` fresh_exp_names) ; m kbs } ; wrapGenSyms fresh_names term } where @@ -1089,6 +981,15 @@ repLKind ki ; foldrM f ki'_rep kis_rep } +-- | Represent a kind wrapped in a Maybe +repMaybeLKind :: Maybe (LHsKind Name) + -> DsM (Core (Maybe TH.Kind)) +repMaybeLKind Nothing = + do { coreNothing kindTyConName } +repMaybeLKind (Just ki) = + do { ki' <- repLKind ki + ; coreJust kindTyConName ki' } + repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind) repNonArrowLKind (L _ ki) = repNonArrowKind ki @@ -1631,13 +1532,6 @@ addBinds :: [GenSymBind] -> DsM a -> DsM a -- by the desugarer monad) addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m -dupBinder :: (Name, Name) -> DsM (Name, DsMetaVal) -dupBinder (new, old) - = do { mb_val <- dsLookupMetaEnv old - ; case mb_val of - Just val -> return (new, val) - Nothing -> pprPanic "dupBinder" (ppr old) } - -- Look up a locally bound name -- lookupLBinder :: Located Name -> DsM (Core TH.Name) @@ -1755,9 +1649,6 @@ dataCon' n args = do { id <- dsLookupDataCon n dataCon :: Name -> DsM (Core a) dataCon n = dataCon' n [] --- Then we make "repConstructors" which use the phantom types for each of the --- smart constructors of the Meta.Meta datatypes. - -- %********************************************************************* -- %* * @@ -1936,20 +1827,23 @@ repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ) repFun (MkC nm) (MkC b) = rep2 funDName [nm, b] repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] - -> Maybe (Core [TH.TypeQ]) + -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind) -> Core [TH.ConQ] -> Core TH.CxtQ -> DsM (Core TH.DecQ) -repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs) - = rep2 dataDName [cxt, nm, tvs, cons, derivs] -repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs) - = rep2 dataInstDName [cxt, nm, tys, cons, derivs] +repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC cons) (MkC derivs) + = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs] +repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC cons) + (MkC derivs) + = rep2 dataInstDName [cxt, nm, tys, ksig, cons, derivs] repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] - -> Maybe (Core [TH.TypeQ]) + -> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.Kind) -> Core TH.ConQ -> Core TH.CxtQ -> DsM (Core TH.DecQ) -repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs) - = rep2 newtypeDName [cxt, nm, tvs, con, derivs] -repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs) - = rep2 newtypeInstDName [cxt, nm, tys, con, derivs] +repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC con) + (MkC derivs) + = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs] +repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC con) + (MkC derivs) + = rep2 newtypeInstDName [cxt, nm, tys, ksig, con, derivs] repTySyn :: Core TH.Name -> Core [TH.TyVarBndr] -> Core TH.TypeQ -> DsM (Core TH.DecQ) @@ -2036,16 +1930,50 @@ repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty] repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ) repCtxt (MkC tys) = rep2 cxtName [tys] -repConstr :: Core TH.Name -> HsConDeclDetails Name +repDataCon :: Located Name + -> HsConDeclDetails Name + -> DsM (Core TH.ConQ) +repDataCon con details + = do con' <- lookupLOcc con -- See Note [Binders and occurrences] + repConstr details Nothing [con'] + +repGadtDataCons :: [Located Name] + -> HsConDeclDetails Name + -> LHsType Name + -> DsM (Core TH.ConQ) +repGadtDataCons cons details res_ty + = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences] + repConstr details (Just res_ty) cons' + +-- Invariant: +-- * for plain H98 data constructors second argument is Nothing and third +-- argument is a singleton list +-- * for GADTs data constructors second argument is (Just return_type) and +-- third argument is a non-empty list +repConstr :: HsConDeclDetails Name + -> Maybe (LHsType Name) + -> [Core TH.Name] -> DsM (Core TH.ConQ) -repConstr con (PrefixCon ps) +repConstr (PrefixCon ps) Nothing [con] = do arg_tys <- repList strictTypeQTyConName repBangTy ps rep2 normalCName [unC con, unC arg_tys] -repConstr con (RecCon (L _ ips)) - = do { args <- concatMapM rep_ip ips - ; arg_vtys <- coreList varStrictTypeQTyConName args - ; rep2 recCName [unC con, unC arg_vtys] } +repConstr (PrefixCon ps) (Just res_ty) cons + = do arg_tys <- repList strictTypeQTyConName repBangTy ps + (res_n, idx) <- repGadtReturnTy res_ty + rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_n + , unC idx] + +repConstr (RecCon (L _ ips)) resTy cons + = do args <- concatMapM rep_ip ips + arg_vtys <- coreList varStrictTypeQTyConName args + case resTy of + Nothing -> rep2 recCName [unC (head cons), unC arg_vtys] + Just res_ty -> do + (res_n, idx) <- repGadtReturnTy res_ty + rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys, + unC res_n, unC idx] + where rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip) @@ -2054,11 +1982,23 @@ repConstr con (RecCon (L _ ips)) ; MkC ty <- repBangTy t ; rep2 varStrictTypeName [v,ty] } -repConstr con (InfixCon st1 st2) +repConstr (InfixCon st1 st2) Nothing [con] = do arg1 <- repBangTy st1 arg2 <- repBangTy st2 rep2 infixCName [unC arg1, unC con, unC arg2] +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 diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index d4e225a8d8..8d8437888c 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -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 diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index 3f49f42a0e..bcb47e4cf6 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -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] diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index 38f06264a2..1751b96fd5 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -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 } diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 1c2d383dbf..a2bdc04f2d 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 39a3d0ef57..5da1bab6a8 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -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: diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs index 571487a274..d683b1a9b4 100644 --- a/compiler/prelude/THNames.hs +++ b/compiler/prelude/THNames.hs @@ -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, diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index 119efc1c20..4c968617bd 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -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 _ = [] diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index ebcab850be..dc6b7a6d2b 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -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) } diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index e5090a074e..9cce515e8f 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -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 diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 47b2fc2766..dc7f0f4692 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -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 diff --git a/docs/users_guide/7.12.1-notes.rst b/docs/users_guide/7.12.1-notes.rst index 9bac1c556f..14af3a0a9e 100644 --- a/docs/users_guide/7.12.1-notes.rst +++ b/docs/users_guide/7.12.1-notes.rst @@ -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 diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs index a41faf5fb1..66d507cf9d 100644 --- a/libraries/template-haskell/Language/Haskell/TH.hs +++ b/libraries/template-haskell/Language/Haskell/TH.hs @@ -121,7 +121,9 @@ module Language.Haskell.TH( -- **** Strictness isStrict, notStrict, strictType, varStrictType, -- **** Class Contexts - cxt, classP, equalP, normalC, recC, infixC, forallC, + cxt, classP, equalP, + -- **** Constructors + normalC, recC, infixC, forallC, gadtC, recGadtC, -- *** Kinds varK, conK, tupleK, arrowK, listK, appK, starK, constraintK, diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index 71e614b1ac..737b9d42c7 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -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 ) +import Control.Monad( liftM, liftM2, liftM3 ) import Data.Word( Word8 ) ---------------------------------------------------------- @@ -338,21 +338,21 @@ funD nm cs = tySynD :: Name -> [TyVarBndr] -> TypeQ -> DecQ tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) } -dataD :: CxtQ -> Name -> [TyVarBndr] -> [ConQ] -> CxtQ -> DecQ -dataD ctxt tc tvs cons derivs = +dataD :: CxtQ -> Name -> [TyVarBndr] -> Maybe Kind -> [ConQ] -> CxtQ -> DecQ +dataD ctxt tc tvs ksig cons derivs = do ctxt1 <- ctxt cons1 <- sequence cons derivs1 <- derivs - return (DataD ctxt1 tc tvs cons1 derivs1) + return (DataD ctxt1 tc tvs ksig cons1 derivs1) -newtypeD :: CxtQ -> Name -> [TyVarBndr] -> ConQ -> CxtQ -> DecQ -newtypeD ctxt tc tvs con derivs = +newtypeD :: CxtQ -> Name -> [TyVarBndr] -> Maybe Kind -> ConQ -> CxtQ -> DecQ +newtypeD ctxt tc tvs ksig con derivs = do ctxt1 <- ctxt con1 <- con derivs1 <- derivs - return (NewtypeD ctxt1 tc tvs con1 derivs1) + return (NewtypeD ctxt1 tc tvs ksig con1 derivs1) classD :: CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [DecQ] -> DecQ classD ctxt cls tvs fds decs = @@ -425,23 +425,23 @@ pragAnnD target expr pragLineD :: Int -> String -> DecQ pragLineD line file = return $ PragmaD $ LineP line file -dataInstD :: CxtQ -> Name -> [TypeQ] -> [ConQ] -> CxtQ -> DecQ -dataInstD ctxt tc tys cons derivs = +dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> [ConQ] -> CxtQ -> DecQ +dataInstD ctxt tc tys ksig cons derivs = do ctxt1 <- ctxt tys1 <- sequence tys cons1 <- sequence cons derivs1 <- derivs - return (DataInstD ctxt1 tc tys1 cons1 derivs1) + return (DataInstD ctxt1 tc tys1 ksig cons1 derivs1) -newtypeInstD :: CxtQ -> Name -> [TypeQ] -> ConQ -> CxtQ -> DecQ -newtypeInstD ctxt tc tys con derivs = +newtypeInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> ConQ -> CxtQ -> DecQ +newtypeInstD ctxt tc tys ksig con derivs = do ctxt1 <- ctxt tys1 <- sequence tys con1 <- con derivs1 <- derivs - return (NewtypeInstD ctxt1 tc tys1 con1 derivs1) + return (NewtypeInstD ctxt1 tc tys1 ksig con1 derivs1) tySynInstD :: Name -> TySynEqnQ -> DecQ tySynInstD tc eqn = @@ -543,6 +543,13 @@ 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) + +recGadtC :: [Name] -> [VarStrictTypeQ] -> Name -> [TypeQ] -> ConQ +recGadtC cons varstrtys ty idx = liftM3 (RecGadtC cons) (sequence varstrtys) + (return ty) (sequence idx) ------------------------------------------------------------------------------- -- * Type diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index 0a7f98da70..bf240f4ec5 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -128,8 +128,8 @@ pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat ap <+> text "->" <+> ppr e pprExp i (LamCaseE ms) = parensIf (i > noPrec) $ text "\\case" $$ nest nestDepth (ppr ms) -pprExp _ (TupE es) = parens $ sep $ punctuate comma $ map ppr es -pprExp _ (UnboxedTupE es) = hashParens $ sep $ punctuate comma $ map ppr es +pprExp _ (TupE es) = parens (commaSep es) +pprExp _ (UnboxedTupE es) = hashParens (commaSep es) -- Nesting in Cond is to avoid potential problems in do statments pprExp i (CondE guard true false) = parensIf (i > noPrec) $ sep [text "if" <+> ppr guard, @@ -146,7 +146,7 @@ pprExp i (LetE ds_ e) = parensIf (i > noPrec) $ text "let" <+> pprDecs ds_ where pprDecs [] = empty pprDecs [d] = ppr d - pprDecs ds = braces $ sep $ punctuate semi $ map ppr ds + pprDecs ds = braces (semiSep ds) pprExp i (CaseE e ms) = parensIf (i > noPrec) $ text "case" <+> ppr e <+> text "of" @@ -155,18 +155,18 @@ pprExp i (DoE ss_) = parensIf (i > noPrec) $ text "do" <+> pprStms ss_ where pprStms [] = empty pprStms [s] = ppr s - pprStms ss = braces $ sep $ punctuate semi $ map ppr ss + pprStms ss = braces (semiSep ss) pprExp _ (CompE []) = text "<<Empty CompExp>>" -- This will probably break with fixity declarations - would need a ';' pprExp _ (CompE ss) = text "[" <> ppr s <+> text "|" - <+> (sep $ punctuate comma $ map ppr ss') + <+> commaSep ss' <> text "]" where s = last ss ss' = init ss pprExp _ (ArithSeqE d) = ppr d -pprExp _ (ListE es) = brackets $ sep $ punctuate comma $ map ppr es +pprExp _ (ListE es) = brackets (commaSep es) pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> dcolon <+> ppr t pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs) pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs) @@ -184,10 +184,10 @@ pprMaybeExp i (Just e) = pprExp i e ------------------------------ instance Ppr Stmt where ppr (BindS p e) = ppr p <+> text "<-" <+> ppr e - ppr (LetS ds) = text "let" <+> (braces $ sep $ punctuate semi $ map ppr ds) + ppr (LetS ds) = text "let" <+> (braces (semiSep ds)) ppr (NoBindS e) = ppr e ppr (ParS sss) = sep $ punctuate (text "|") - $ map (sep . punctuate comma . map ppr) sss + $ map commaSep sss ------------------------------ instance Ppr Match where @@ -245,8 +245,8 @@ instance Ppr Pat where pprPat :: Precedence -> Pat -> Doc pprPat i (LitP l) = pprLit i l pprPat _ (VarP v) = pprName' Applied v -pprPat _ (TupP ps) = parens $ sep $ punctuate comma $ map ppr ps -pprPat _ (UnboxedTupP ps) = hashParens $ sep $ punctuate comma $ map ppr ps +pprPat _ (TupP ps) = parens (commaSep ps) +pprPat _ (UnboxedTupP ps) = hashParens (commaSep ps) pprPat i (ConP s ps) = parensIf (i >= appPrec) $ pprName' Applied s <+> sep (map (pprPat appPrec) ps) pprPat _ (ParensP p) = parens $ pprPat noPrec p @@ -267,7 +267,7 @@ pprPat _ (RecP nm fs) = parens $ ppr nm <+> braces (sep $ punctuate comma $ map (\(s,p) -> ppr s <+> equals <+> ppr p) fs) -pprPat _ (ListP ps) = brackets $ sep $ punctuate comma $ map ppr ps +pprPat _ (ListP ps) = brackets (commaSep ps) pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> dcolon <+> ppr t pprPat _ (ViewP e p) = parens $ pprExp noPrec e <+> text "->" <+> pprPat noPrec p @@ -283,10 +283,10 @@ ppr_dec _ (ValD p r ds) = ppr p <+> pprBody True r $$ where_clause ds ppr_dec _ (TySynD t xs rhs) = ppr_tySyn empty t (hsep (map ppr xs)) rhs -ppr_dec _ (DataD ctxt t xs cs decs) - = ppr_data empty ctxt t (hsep (map ppr xs)) cs decs -ppr_dec _ (NewtypeD ctxt t xs c decs) - = ppr_newtype empty ctxt t (sep (map ppr xs)) c decs +ppr_dec _ (DataD ctxt t xs ksig cs decs) + = ppr_data empty ctxt t (hsep (map ppr xs)) ksig cs decs +ppr_dec _ (NewtypeD ctxt t xs ksig c decs) + = ppr_newtype empty ctxt t (sep (map ppr xs)) ksig c decs ppr_dec _ (ClassD ctxt c xs fds ds) = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds $$ where_clause ds @@ -303,13 +303,13 @@ ppr_dec isTop (DataFamilyD tc tvs kind) | otherwise = empty maybeKind | (Just k') <- kind = dcolon <+> ppr k' | otherwise = empty -ppr_dec isTop (DataInstD ctxt tc tys cs decs) - = ppr_data maybeInst ctxt tc (sep (map pprParendType tys)) cs decs +ppr_dec isTop (DataInstD ctxt tc tys ksig cs decs) + = ppr_data maybeInst ctxt tc (sep (map pprParendType tys)) ksig cs decs where maybeInst | isTop = text "instance" | otherwise = empty -ppr_dec isTop (NewtypeInstD ctxt tc tys c decs) - = ppr_newtype maybeInst ctxt tc (sep (map pprParendType tys)) c decs +ppr_dec isTop (NewtypeInstD ctxt tc tys ksig c decs) + = ppr_newtype maybeInst ctxt tc (sep (map pprParendType tys)) ksig c decs where maybeInst | isTop = text "instance" | otherwise = empty @@ -339,11 +339,11 @@ ppr_dec _ (StandaloneDerivD cxt ty) ppr_dec _ (DefaultSigD n ty) = hsep [ text "default", pprPrefixOcc n, dcolon, ppr ty ] -ppr_data :: Doc -> Cxt -> Name -> Doc -> [Con] -> Cxt -> Doc -ppr_data maybeInst ctxt t argsDoc cs decs +ppr_data :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> [Con] -> Cxt -> Doc +ppr_data maybeInst ctxt t argsDoc ksig cs decs = sep [text "data" <+> maybeInst <+> pprCxt ctxt - <+> ppr t <+> argsDoc, + <+> ppr t <+> argsDoc <+> ksigDoc <+> maybeWhere, nest nestDepth (sep (pref $ map ppr cs)), if null decs then empty @@ -351,19 +351,39 @@ ppr_data maybeInst ctxt t argsDoc cs decs $ text "deriving" <+> ppr_cxt_preds decs] where pref :: [Doc] -> [Doc] - pref [] = [] -- No constructors; can't happen in H98 - pref (d:ds) = (char '=' <+> d):map (char '|' <+>) ds - -ppr_newtype :: Doc -> Cxt -> Name -> Doc -> Con -> Cxt -> Doc -ppr_newtype maybeInst ctxt t argsDoc c decs + pref xs | isGadtDecl = xs + pref [] = [] -- No constructors; can't happen in H98 + pref (d:ds) = (char '=' <+> d):map (char '|' <+>) ds + + maybeWhere :: Doc + maybeWhere | isGadtDecl = text "where" + | otherwise = empty + + isGadtDecl :: Bool + isGadtDecl = not (null cs) && all isGadtCon cs + where isGadtCon (GadtC _ _ _ _ ) = True + isGadtCon (RecGadtC _ _ _ _) = True + isGadtCon (ForallC _ _ x ) = isGadtCon x + isGadtCon _ = False + + ksigDoc = case ksig of + Nothing -> empty + Just k -> dcolon <+> ppr k + +ppr_newtype :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> Con -> Cxt -> Doc +ppr_newtype maybeInst ctxt t argsDoc ksig c decs = sep [text "newtype" <+> maybeInst <+> pprCxt ctxt - <+> ppr t <+> argsDoc, + <+> ppr t <+> argsDoc <+> ksigDoc, nest 2 (char '=' <+> ppr c), if null decs then empty else nest nestDepth $ text "deriving" <+> ppr_cxt_preds decs] + where + ksigDoc = case ksig of + Nothing -> empty + Just k -> dcolon <+> ppr k ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc ppr_tySyn maybeInst t argsDoc rhs @@ -380,7 +400,7 @@ ppr_tf_head (TypeFamilyHead tc tvs res inj) instance Ppr FunDep where ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys) ppr_list [] = empty - ppr_list xs = char '|' <+> sep (punctuate (text ", ") (map ppr xs)) + ppr_list xs = char '|' <+> commaSep xs ------------------------------ instance Ppr FamFlavour where @@ -478,13 +498,46 @@ instance Ppr Clause where ------------------------------ instance Ppr Con where ppr (NormalC c sts) = ppr c <+> sep (map pprStrictType sts) + ppr (RecC c vsts) = ppr c <+> braces (sep (punctuate comma $ map pprVarStrictType vsts)) + ppr (InfixC st1 c st2) = pprStrictType st1 <+> pprName' Infix c <+> pprStrictType st2 - ppr (ForallC ns ctxt con) = text "forall" <+> hsep (map ppr ns) - <+> char '.' <+> sep [pprCxt ctxt, ppr con] + + ppr (ForallC ns ctxt (GadtC c sts ty idx)) + = commaSep c <+> dcolon <+> pprForall ns ctxt <+> pprGadtRHS sts ty idx + + ppr (ForallC ns ctxt (RecGadtC c vsts ty idx)) + = commaSep c <+> dcolon <+> pprForall ns ctxt + <+> pprRecFields vsts ty idx + + ppr (ForallC ns ctxt con) + = pprForall ns ctxt <+> ppr con + + ppr (GadtC c sts ty idx) + = commaSep c <+> dcolon <+> pprGadtRHS sts ty idx + + ppr (RecGadtC c vsts ty idx) + = commaSep c <+> dcolon <+> pprRecFields vsts ty idx + +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 + = braces (sep (punctuate comma $ map pprVarStrictType vsts)) + <+> arrow <+> ppr ty <+> sep (map ppr idx) + +pprGadtRHS :: [(Strict, Type)] -> Name -> [Type] -> Doc +pprGadtRHS [] ty idx + = ppr ty <+> sep (map ppr idx) +pprGadtRHS sts ty idx + = sep (punctuate (space <> arrow) (map pprStrictType sts)) + <+> arrow <+> ppr ty <+> sep (map ppr idx) ------------------------------ pprVarStrictType :: (Name, Strict, Type) -> Doc @@ -548,9 +601,9 @@ pprTyApp (EqualityT, [arg1, arg2]) = sep [pprFunArgType arg1 <+> text "~", ppr arg2] pprTyApp (ListT, [arg]) = brackets (ppr arg) pprTyApp (TupleT n, args) - | length args == n = parens (sep (punctuate comma (map ppr args))) + | length args == n = parens (commaSep args) pprTyApp (PromotedTupleT n, args) - | length args == n = quoteParens (sep (punctuate comma (map ppr args))) + | length args == n = quoteParens (commaSep args) pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendType args) pprFunArgType :: Type -> Doc -- Should really use a precedence argument @@ -591,7 +644,7 @@ pprCxt ts = ppr_cxt_preds ts <+> text "=>" ppr_cxt_preds :: Cxt -> Doc ppr_cxt_preds [] = empty ppr_cxt_preds [t] = ppr t -ppr_cxt_preds ts = parens (sep $ punctuate comma $ map ppr ts) +ppr_cxt_preds ts = parens (commaSep ts) ------------------------------ instance Ppr Range where @@ -629,3 +682,13 @@ instance Ppr Loc where , parens $ int start_ln <> comma <> int start_col , text "-" , parens $ int end_ln <> comma <> int end_col ] + +-- Takes a list of printable things and prints them separated by commas followed +-- by space. +commaSep :: Ppr a => [a] -> Doc +commaSep = sep . punctuate comma . map ppr + +-- Takes a list of printable things and prints them separated by semicolons +-- followed by space. +semiSep :: Ppr a => [a] -> Doc +semiSep = sep . punctuate semi . map ppr diff --git a/libraries/template-haskell/Language/Haskell/TH/PprLib.hs b/libraries/template-haskell/Language/Haskell/TH/PprLib.hs index 1a99207807..acef3274b5 100644 --- a/libraries/template-haskell/Language/Haskell/TH/PprLib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/PprLib.hs @@ -21,10 +21,10 @@ module Language.Haskell.TH.PprLib ( parens, brackets, braces, quotes, doubleQuotes, -- * Combining documents - (<>), (<+>), hcat, hsep, - ($$), ($+$), vcat, - sep, cat, - fsep, fcat, + (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, nest, hang, punctuate, @@ -98,8 +98,8 @@ hcat :: [Doc] -> Doc; -- ^List version of '<>' hsep :: [Doc] -> Doc; -- ^List version of '<+>' ($$) :: Doc -> Doc -> Doc; -- ^Above; if there is no - -- overlap it \"dovetails\" the two -($+$) :: Doc -> Doc -> Doc; -- ^Above, without dovetailing. + -- overlap it \"dovetails\" the two +($+$) :: Doc -> Doc -> Doc; -- ^Above, without dovetailing. vcat :: [Doc] -> Doc; -- ^List version of '$$' cat :: [Doc] -> Doc; -- ^ Either hcat or vcat @@ -112,9 +112,9 @@ nest :: Int -> Doc -> Doc; -- ^ Nested -- GHC-specific ones. -hang :: Doc -> Int -> Doc -> Doc; -- ^ @hang d1 n d2 = sep [d1, nest n d2]@ -punctuate :: Doc -> [Doc] -> [Doc]; -- ^ @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@ - +hang :: Doc -> Int -> Doc -> Doc; -- ^ @hang d1 n d2 = sep [d1, nest n d2]@ +punctuate :: Doc -> [Doc] -> [Doc] + -- ^ @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@ -- --------------------------------------------------------------------------- -- The "implementation" @@ -227,4 +227,3 @@ punctuate p (d:ds) = go d ds where go d' [] = [d'] go d' (e:es) = (d' <> p) : go e es - diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index a9a8c39ab2..b333b006b6 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -1473,10 +1473,13 @@ data Dec = FunD Name [Clause] -- ^ @{ f p1 p2 = b where decs }@ | ValD Pat Body [Dec] -- ^ @{ p = b where decs }@ | DataD Cxt Name [TyVarBndr] - [Con] Cxt -- ^ @{ data Cxt x => T x = A x | B (T x) - -- deriving (Z,W Q)}@ + (Maybe Kind) -- Kind signature (allowed only for GADTs) + [Con] Cxt + -- ^ @{ data Cxt x => T x = A x | B (T x) + -- deriving (Z,W)}@ | NewtypeD Cxt Name [TyVarBndr] - Con Cxt -- ^ @{ newtype Cxt x => T x = A (B x) + (Maybe Kind) -- Kind signature + Con Cxt -- ^ @{ newtype Cxt x => T x = A (B x) -- deriving (Z,W Q)}@ | TySynD Name [TyVarBndr] Type -- ^ @{ type T x = (x,x) }@ | ClassD Cxt Name [TyVarBndr] @@ -1498,12 +1501,14 @@ data Dec -- ^ @{ data family T a b c :: * }@ | DataInstD Cxt Name [Type] - [Con] Cxt -- ^ @{ data instance Cxt x => T [x] = A x - -- | B (T x) - -- deriving (Z,W Q)}@ + (Maybe Kind) -- Kind signature + [Con] Cxt -- ^ @{ data instance Cxt x => T [x] + -- = A x | B (T x) deriving (Z,W)}@ + | NewtypeInstD Cxt Name [Type] - Con Cxt -- ^ @{ newtype instance Cxt x => T [x] = A (B x) - -- deriving (Z,W)}@ + (Maybe Kind) -- Kind signature + Con Cxt -- ^ @{ newtype instance Cxt x => T [x] + -- = A (B x) deriving (Z,W)}@ | TySynInstD Name TySynEqn -- ^ @{ type instance ... }@ -- | open type families (may also appear in [Dec] of 'ClassD' and 'InstanceD') @@ -1591,12 +1596,31 @@ type Pred = Type data Strict = IsStrict | NotStrict | Unpacked deriving( Show, Eq, Ord, Data, Typeable, Generic ) -data Con = NormalC Name [StrictType] -- ^ @C Int a@ - | RecC Name [VarStrictType] -- ^ @C { v :: Int, w :: a }@ - | InfixC StrictType Name StrictType -- ^ @Int :+ a@ - | ForallC [TyVarBndr] Cxt Con -- ^ @forall a. Eq a => C [a]@ +data Con = NormalC Name [StrictType] -- ^ @C Int a@ + | RecC Name [VarStrictType] -- ^ @C { v :: Int, w :: a }@ + | InfixC StrictType Name StrictType -- ^ @Int :+ a@ + | ForallC [TyVarBndr] Cxt Con -- ^ @forall a. Eq a => C [a]@ + | GadtC [Name] [StrictType] + Name -- See Note [GADT return type] + [Type] -- Indices of the type constructor + -- ^ @C :: a -> b -> T b Int@ + | RecGadtC [Name] [VarStrictType] + Name -- See Note [GADT return type] + [Type] -- Indices of the type constructor + -- ^ @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: +-- +-- type S = T +-- +-- data T a where +-- MkT :: S Int + type StrictType = (Strict, Type) type VarStrictType = (Name, Strict, Type) diff --git a/testsuite/tests/overloadedrecflds/should_fail/T11103.hs b/testsuite/tests/overloadedrecflds/should_fail/T11103.hs index 2ba8e41a22..2791dc4fca 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/T11103.hs +++ b/testsuite/tests/overloadedrecflds/should_fail/T11103.hs @@ -12,7 +12,7 @@ data S = MkS { foo :: Int } $(do info <- reify ''R case info of - TyConI (DataD _ _ _ [RecC _ [(foo_n, _, _), (bar_n, _, _)]] _) + TyConI (DataD _ _ _ _ [RecC _ [(foo_n, _, _), (bar_n, _, _)]] _) -> do { reify bar_n -- This is unambiguous ; reify foo_n -- This is ambiguous ; return [] diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.hs index e70c5db7b1..e97fdcea9a 100644 --- a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.hs +++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.hs @@ -6,7 +6,8 @@ import Language.Haskell.TH import Language.Haskell.TH.Syntax -- Splice in a datatype with field... -$(return [DataD [] (mkName "R") [] [RecC (mkName "MkR") [(mkName "foo", NotStrict, ConT ''Int)]] []]) +$(return [DataD [] (mkName "R") [] Nothing + [RecC (mkName "MkR") [(mkName "foo", NotStrict, ConT ''Int)]] []]) -- New TH story means reify only sees R if we do this: $(return []) @@ -14,7 +15,7 @@ $(return []) -- ... and check that we can inspect it main = do putStrLn $(do { info <- reify ''R ; case info of - TyConI (DataD _ _ _ [RecC _ [(n, _, _)]] _) -> + TyConI (DataD _ _ _ _ [RecC _ [(n, _, _)]] _) -> do { info' <- reify n ; lift (pprint info ++ "\n" ++ pprint info') } diff --git a/testsuite/tests/rts/T7919A.hs b/testsuite/tests/rts/T7919A.hs index 4bca2add1f..4dc013aeff 100644 --- a/testsuite/tests/rts/T7919A.hs +++ b/testsuite/tests/rts/T7919A.hs @@ -19,6 +19,7 @@ largeData = (cxt []) (dataName) [] + Nothing [normalC dataName (replicate size (((,) <$> notStrict) `ap` [t| Int |]))] (cxt []) diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang11_B.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang11_B.hs index 8d81be6abc..ec4f7c9bbf 100644 --- a/testsuite/tests/safeHaskell/safeLanguage/SafeLang11_B.hs +++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang11_B.hs @@ -8,7 +8,7 @@ class Class a where mkSimpleClass :: Name -> Q [Dec] mkSimpleClass name = do - TyConI (DataD [] dname [] cs _) <- reify name + TyConI (DataD [] dname [] Nothing cs _) <- reify name ((NormalC conname []):_) <- return cs ClassI (ClassD [] cname [_] [] [SigD mname _]) _ <- reify ''Class return [InstanceD [] (AppT (ConT cname) (ConT dname)) [FunD mname diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang12_B.hs b/testsuite/tests/safeHaskell/safeLanguage/SafeLang12_B.hs index 1e5b2252cb..af7e5cf5b1 100644 --- a/testsuite/tests/safeHaskell/safeLanguage/SafeLang12_B.hs +++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang12_B.hs @@ -9,7 +9,7 @@ class Class a where mkSimpleClass :: Name -> Q [Dec] mkSimpleClass name = do - TyConI (DataD [] dname [] cs _) <- reify name + TyConI (DataD [] dname [] Nothing cs _) <- reify name ((NormalC conname []):_) <- return cs ClassI (ClassD [] cname [_] [] [SigD mname _]) _ <- reify ''Class return [InstanceD [] (AppT (ConT cname) (ConT dname)) [FunD mname diff --git a/testsuite/tests/th/T10819_Lib.hs b/testsuite/tests/th/T10819_Lib.hs index aa52a181fd..94f352efe7 100644 --- a/testsuite/tests/th/T10819_Lib.hs +++ b/testsuite/tests/th/T10819_Lib.hs @@ -2,5 +2,6 @@ module T10819_Lib where import Language.Haskell.TH.Syntax -doSomeTH s tp drv = return [NewtypeD [] n [] (NormalC n [(NotStrict, ConT tp)]) drv] +doSomeTH s tp drv = return [NewtypeD [] n [] Nothing + (NormalC n [(NotStrict, ConT tp)]) drv] where n = mkName s diff --git a/testsuite/tests/th/T10828.hs b/testsuite/tests/th/T10828.hs new file mode 100644 index 0000000000..f01c5b9769 --- /dev/null +++ b/testsuite/tests/th/T10828.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE TemplateHaskell, GADTs, ExplicitForAll, KindSignatures, + TypeFamilies, DataKinds #-} + +module T10828 where + +import Language.Haskell.TH +import System.IO + +$( do { decl <- [d| data family D a :: * -> * + data instance D Int Bool :: * where + DInt :: D Int Bool + + data E where + MkE :: a -> E + + data Foo a b where + MkFoo, MkFoo' :: a -> Foo a b + + newtype Bar :: * -> Bool -> * where + MkBar :: a -> Bar a b + |] + + ; runIO $ putStrLn (pprint decl) >> hFlush stdout + ; return decl } + ) + +-- data T a :: * where +-- MkT :: a -> a -> T a +-- MkC :: forall a b. (a ~ Int) => { foo :: a, bar :: b } -> T Int + +$( return + [ DataD [] (mkName "T") + [ PlainTV (mkName "a") ] + (Just StarT) + [ GadtC [(mkName "MkT")] + [ (NotStrict, VarT (mkName "a")) + , (NotStrict, VarT (mkName "a"))] + ( mkName "T" ) + [ VarT (mkName "a") ] + , ForallC [PlainTV (mkName "a"), PlainTV (mkName "b")] + [AppT (AppT EqualityT (VarT $ mkName "a" ) ) + (ConT $ mkName "Int") ] $ + RecGadtC [(mkName "MkC")] + [ (mkName "foo", NotStrict, VarT (mkName "a")) + , (mkName "bar", NotStrict, VarT (mkName "b"))] + ( mkName "T" ) + [ ConT (mkName "Int") ] ] + [] ]) + +$( do { -- test reification + TyConI dec <- runQ $ reify (mkName "T") + ; runIO $ putStrLn (pprint dec) >> hFlush stdout + + -- test quoting + ; d <- runQ $ [d| + data T' a :: * where + MkT' :: a -> a -> T' a + MkC' :: forall a b. (a ~ Int) => { foo :: a, bar :: b } + -> T' Int |] + ; runIO $ putStrLn (pprint d) >> hFlush stdout + ; return [] } ) diff --git a/testsuite/tests/th/T10828.stderr b/testsuite/tests/th/T10828.stderr new file mode 100644 index 0000000000..91653f9ab3 --- /dev/null +++ b/testsuite/tests/th/T10828.stderr @@ -0,0 +1,100 @@ +data family D_0 a_1 :: * -> * +data instance D_0 GHC.Types.Int GHC.Types.Bool :: * where + DInt_2 :: D_0 GHC.Types.Int GHC.Types.Bool +data E_3 where MkE_4 :: forall a_5 . a_5 -> E_3 +data Foo_6 a_7 b_8 where + MkFoo_9, MkFoo'_10 :: forall a_11 b_12 . a_11 -> Foo_6 a_11 b_12 +newtype Bar_13 :: * -> GHC.Types.Bool -> * + = MkBar_14 :: forall a_15 b_16 . a_15 -> Bar_13 a_15 b_16 +data T10828.T (a_0 :: *) where + T10828.MkT :: forall (a_1 :: *) . a_1 -> a_1 -> T10828.T a_1 + T10828.MkC :: forall (a_2 :: *) (b_3 :: *) . Data.Type.Equality.~ a_2 + GHC.Types.Int => {T10828.foo :: a_2, + T10828.bar :: b_3} -> T10828.T GHC.Types.Int +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"#) diff --git a/testsuite/tests/th/T10828a.hs b/testsuite/tests/th/T10828a.hs new file mode 100644 index 0000000000..8bf13cfb04 --- /dev/null +++ b/testsuite/tests/th/T10828a.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TemplateHaskell, GADTs, ExplicitForAll, KindSignatures #-} + +module T10828a where + +import Language.Haskell.TH +import System.IO + +-- attempting to place a kind signature on a H98 data type +$( return + [ DataD [] (mkName "T") + [ PlainTV (mkName "a") ] + (Just StarT) + [ NormalC (mkName "MkT") + [ (NotStrict, VarT (mkName "a")) + , (NotStrict, VarT (mkName "a"))] + ] + [] ]) diff --git a/testsuite/tests/th/T10828a.stderr b/testsuite/tests/th/T10828a.stderr new file mode 100644 index 0000000000..9c05b83190 --- /dev/null +++ b/testsuite/tests/th/T10828a.stderr @@ -0,0 +1,4 @@ + +T10828a.hs:9:4: + Kind signatures are only allowed on GADTs + When splicing a TH declaration: data T a :: * = MkT a a diff --git a/testsuite/tests/th/T10828b.hs b/testsuite/tests/th/T10828b.hs new file mode 100644 index 0000000000..55d8889009 --- /dev/null +++ b/testsuite/tests/th/T10828b.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TemplateHaskell, GADTs, ExplicitForAll, KindSignatures #-} + +module T10828b where + +import Language.Haskell.TH +import System.IO + +-- attempting to mix GADT and normal constructors +$( return + [ DataD [] (mkName "T") + [ PlainTV (mkName "a") ] + (Just StarT) + [ NormalC (mkName "MkT") + [ (NotStrict, VarT (mkName "a")) + , (NotStrict, VarT (mkName "a"))] + , ForallC [PlainTV (mkName "a")] + [AppT (AppT EqualityT (VarT $ mkName "a" ) ) + (ConT $ mkName "Int") ] $ + RecGadtC [(mkName "MkC")] + [ (mkName "foo", NotStrict, VarT (mkName "a")) + , (mkName "bar", NotStrict, VarT (mkName "b"))] + ( mkName "T" ) + [ ConT (mkName "Int") ] + ] + [] ]) diff --git a/testsuite/tests/th/T10828b.stderr b/testsuite/tests/th/T10828b.stderr new file mode 100644 index 0000000000..bbc57dd3ab --- /dev/null +++ b/testsuite/tests/th/T10828b.stderr @@ -0,0 +1,7 @@ + +T10828b.hs:9:4: + Cannot mix GADT constructors with Haskell 98 constructors + When splicing a TH declaration: + data T a :: * + = MkT a a + | MkC :: forall a . a ~ Int => {foo :: a, bar :: b} -> T Int diff --git a/testsuite/tests/th/T4188.stderr b/testsuite/tests/th/T4188.stderr index bea2e80674..2e4155fd8b 100644 --- a/testsuite/tests/th/T4188.stderr +++ b/testsuite/tests/th/T4188.stderr @@ -1,9 +1,8 @@ data T4188.T1 (a_0 :: *) = forall (b_1 :: *) . T4188.MkT1 a_0 b_1 data T4188.T2 (a_0 :: *) - = forall (b_1 :: *) . (T4188.C a_0, T4188.C b_1) => - T4188.MkT2 a_0 b_1 -data T4188.T3 (x_0 :: *) - = forall (x_1 :: *) (y_2 :: *) . (x_0 ~ (x_1, y_2), - T4188.C x_1, - T4188.C y_2) => - T4188.MkT3 x_1 y_2 + = forall (b_1 :: *) . (T4188.C a_0, T4188.C b_1) => T4188.MkT2 a_0 + b_1 +data T4188.T3 (x_0 :: *) where + T4188.MkT3 :: forall (x_1 :: *) (y_2 :: *) . (T4188.C x_1, + T4188.C y_2) => x_1 -> y_2 -> T4188.T3 (x_1, y_2) + diff --git a/testsuite/tests/th/T5217.hs b/testsuite/tests/th/T5217.hs index 9dd1f1cb3f..ea28c74921 100644 --- a/testsuite/tests/th/T5217.hs +++ b/testsuite/tests/th/T5217.hs @@ -1,11 +1,9 @@ -{-# LANGUAGE GADTs #-}
-
-module T5217 where
-import Language.Haskell.TH
-
-$([d| data T a b where { T1 :: Int -> T Int Char
- ; T2 :: a -> T a a
- ; T3 :: a -> T [a] a
- ; T4 :: a -> b -> T b [a] } |])
-
-
+{-# LANGUAGE GADTs #-} + +module T5217 where +import Language.Haskell.TH + +$([d| data T a b where { T1 :: Int -> T Int Char + ; T2 :: a -> T a a + ; T3 :: a -> T [a] a + ; T4 :: a -> b -> T b [a] } |]) diff --git a/testsuite/tests/th/T5217.stderr b/testsuite/tests/th/T5217.stderr index f69875b31f..fe9150d90b 100644 --- a/testsuite/tests/th/T5217.stderr +++ b/testsuite/tests/th/T5217.stderr @@ -7,7 +7,8 @@ T5217.hs:(6,3)-(9,53): Splicing declarations T4 :: a -> b -> T b [a] |]
======>
data T a b
- = (b ~ Char, a ~ Int) => T1 Int |
- b ~ a => T2 a |
- a ~ [b] => T3 b |
- forall a. b ~ [a] => T4 a a
+ where
+ T1 :: Int -> T Int Char
+ T2 :: forall a. a -> T a a
+ T3 :: forall a. a -> T [a] a
+ T4 :: forall a b. a -> b -> T b [a]
diff --git a/testsuite/tests/th/T5290.hs b/testsuite/tests/th/T5290.hs index 7973a13d24..50ad2d500c 100644 --- a/testsuite/tests/th/T5290.hs +++ b/testsuite/tests/th/T5290.hs @@ -5,4 +5,4 @@ module T5290 where import Language.Haskell.TH $( let n = mkName "T" - in return [DataD [] n [] [NormalC n [(Unpacked,ConT ''Int)]] []] ) + in return [DataD [] n [] Nothing [NormalC n [(Unpacked,ConT ''Int)]] []] ) diff --git a/testsuite/tests/th/T5290.stderr b/testsuite/tests/th/T5290.stderr index 2b4275d842..d6996d0799 100644 --- a/testsuite/tests/th/T5290.stderr +++ b/testsuite/tests/th/T5290.stderr @@ -1,5 +1,7 @@ -T5290.hs:(7,4)-(8,67): Splicing declarations +T5290.hs:(7,4)-(8,75): Splicing declarations let n = mkName "T" - in return [DataD [] n [] [NormalC n [(Unpacked, ConT ''Int)]] []] + in + return + [DataD [] n [] Nothing [NormalC n [(Unpacked, ConT ''Int)]] []] ======> data T = T {-# UNPACK #-} !Int diff --git a/testsuite/tests/th/T5665a.hs b/testsuite/tests/th/T5665a.hs index eba5a1a168..b34131e974 100644 --- a/testsuite/tests/th/T5665a.hs +++ b/testsuite/tests/th/T5665a.hs @@ -1,6 +1,7 @@ -module T5665a where
-
-import Language.Haskell.TH
-
-doSomeTH s tp = return [NewtypeD [] n [] (NormalC n [(NotStrict, ConT tp)]) []]
- where n = mkName s
+module T5665a where + +import Language.Haskell.TH + +doSomeTH s tp = return [NewtypeD [] n [] Nothing + (NormalC n [(NotStrict, ConT tp)]) []] + where n = mkName s diff --git a/testsuite/tests/th/T5984_Lib.hs b/testsuite/tests/th/T5984_Lib.hs index c3abfa21f9..a929086dd2 100644 --- a/testsuite/tests/th/T5984_Lib.hs +++ b/testsuite/tests/th/T5984_Lib.hs @@ -5,9 +5,10 @@ module T5984_Lib where import Language.Haskell.TH nt :: Q [Dec] -nt = return [NewtypeD [] foo [] (NormalC foo [(NotStrict, ConT ''Int)]) []] +nt = return [NewtypeD [] foo [] Nothing + (NormalC foo [(NotStrict, ConT ''Int)]) []] where foo = mkName "Foo" dt :: Q [Dec] -dt = return [DataD [] bar [] [NormalC bar [(NotStrict, ConT ''Int)]] []] +dt = return [DataD [] bar [] Nothing [NormalC bar [(NotStrict, ConT ''Int)]] []] where bar = mkName "Bar" diff --git a/testsuite/tests/th/T7241.hs b/testsuite/tests/th/T7241.hs index 971a2678f8..8eee28004c 100644 --- a/testsuite/tests/th/T7241.hs +++ b/testsuite/tests/th/T7241.hs @@ -4,4 +4,4 @@ module T7241 where import Language.Haskell.TH -$(newName "Foo" >>= \o -> return [DataD [] o [] [RecC o []] []]) +$(newName "Foo" >>= \o -> return [DataD [] o [] Nothing [RecC o []] []]) diff --git a/testsuite/tests/th/T7532a.hs b/testsuite/tests/th/T7532a.hs index 5a5f45adb7..42976b393c 100644 --- a/testsuite/tests/th/T7532a.hs +++ b/testsuite/tests/th/T7532a.hs @@ -11,5 +11,5 @@ class C a where bang :: DecsQ bang = return [ InstanceD [] (AppT (ConT ''C) (ConT ''Int)) [ - DataInstD [] ''D [ConT ''Int] [ - NormalC (mkName "T") []] []]] + DataInstD [] ''D [ConT ''Int] Nothing [ + NormalC (mkName "T") []] []]] diff --git a/testsuite/tests/th/T8499.hs b/testsuite/tests/th/T8499.hs index 7829e99e53..29b9e1678c 100644 --- a/testsuite/tests/th/T8499.hs +++ b/testsuite/tests/th/T8499.hs @@ -5,7 +5,7 @@ module T8499 where import Language.Haskell.TH -$( do TyConI (DataD _ _ [KindedTV tvb_a _] _ _) <- reify ''Maybe +$( do TyConI (DataD _ _ [KindedTV tvb_a _] _ _ _) <- reify ''Maybe my_a <- newName "a" return [TySynD (mkName "SMaybe") [KindedTV my_a (AppT (ConT ''Maybe) (VarT tvb_a))] diff --git a/testsuite/tests/th/T8624.hs b/testsuite/tests/th/T8624.hs index 49f67d5a33..eda7781132 100644 --- a/testsuite/tests/th/T8624.hs +++ b/testsuite/tests/th/T8624.hs @@ -4,4 +4,5 @@ module T8624 (THDec(..)) where import Language.Haskell.TH -$(return [DataD [] (mkName "THDec") [] [NormalC (mkName "THDec") []] []]) +$(return [DataD [] (mkName "THDec") [] Nothing + [NormalC (mkName "THDec") []] []]) diff --git a/testsuite/tests/th/T8624.stdout b/testsuite/tests/th/T8624.stdout index 82ea19598c..0dcc7b0718 100644 --- a/testsuite/tests/th/T8624.stdout +++ b/testsuite/tests/th/T8624.stdout @@ -1,2 +1,2 @@ --- T8624.hs:7:3-72: Splicing declarations +-- T8624.hs:(7,3)-(8,43): Splicing declarations data THDec = THDec diff --git a/testsuite/tests/th/TH_RichKinds2.stderr b/testsuite/tests/th/TH_RichKinds2.stderr index 4f8729d53c..e141b40396 100644 --- a/testsuite/tests/th/TH_RichKinds2.stderr +++ b/testsuite/tests/th/TH_RichKinds2.stderr @@ -1,8 +1,9 @@ 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) + 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 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) diff --git a/testsuite/tests/th/TH_Roles1.hs b/testsuite/tests/th/TH_Roles1.hs index d746fc9cd8..89d072c485 100644 --- a/testsuite/tests/th/TH_Roles1.hs +++ b/testsuite/tests/th/TH_Roles1.hs @@ -4,6 +4,6 @@ module TH_Roles1 where import Language.Haskell.TH -$( return [ DataD [] (mkName "T") [PlainTV (mkName "a")] [] [] +$( return [ DataD [] (mkName "T") [PlainTV (mkName "a")] Nothing [] [] , RoleAnnotD (mkName "T") [RepresentationalR] ] ) diff --git a/testsuite/tests/th/TH_Roles2.hs b/testsuite/tests/th/TH_Roles2.hs index 30f4fc7631..3f7b535b49 100644 --- a/testsuite/tests/th/TH_Roles2.hs +++ b/testsuite/tests/th/TH_Roles2.hs @@ -4,6 +4,7 @@ module TH_Roles2 where import Language.Haskell.TH -$( return [ DataD [] (mkName "T") [KindedTV (mkName "a") (VarT (mkName "k"))] [] [] +$( return [ DataD [] (mkName "T") [KindedTV (mkName "a") (VarT (mkName "k"))] + Nothing [] [] , RoleAnnotD (mkName "T") [RepresentationalR] ] ) diff --git a/testsuite/tests/th/TH_dataD1.hs b/testsuite/tests/th/TH_dataD1.hs index c28d38b370..1a51ac4aef 100644 --- a/testsuite/tests/th/TH_dataD1.hs +++ b/testsuite/tests/th/TH_dataD1.hs @@ -5,7 +5,8 @@ import Language.Haskell.TH ds :: Q [Dec] ds = [d| - $(do { d <- dataD (cxt []) (mkName "D") [] [normalC (mkName "K") []] (cxt []) + $(do { d <- dataD (cxt []) (mkName "D") [] Nothing + [normalC (mkName "K") []] (cxt []) ; return [d]}) |] diff --git a/testsuite/tests/th/TH_genExLib.hs b/testsuite/tests/th/TH_genExLib.hs index d439231815..5e1ee0bfc0 100644 --- a/testsuite/tests/th/TH_genExLib.hs +++ b/testsuite/tests/th/TH_genExLib.hs @@ -12,7 +12,7 @@ genAny decl = do { d <- decl genAnyClass :: Name -> [Dec] -> Dec genAnyClass name decls - = DataD [] anyName [] [constructor] [] + = DataD [] anyName [] Nothing [constructor] [] where anyName = mkName ("Any" ++ nameBase name ++ "1111") constructor = ForallC [PlainTV var_a] [AppT (ConT name) (VarT var_a)] $ diff --git a/testsuite/tests/th/TH_spliceDecl1.hs b/testsuite/tests/th/TH_spliceDecl1.hs index 618218d3eb..94070a3c69 100644 --- a/testsuite/tests/th/TH_spliceDecl1.hs +++ b/testsuite/tests/th/TH_spliceDecl1.hs @@ -7,4 +7,4 @@ import Language.Haskell.TH -- splice a simple data declaration -$(return [DataD [] (mkName "T") [] [NormalC (mkName "C") []] []]) +$(return [DataD [] (mkName "T") [] Nothing [NormalC (mkName "C") []] []]) diff --git a/testsuite/tests/th/TH_spliceDecl3_Lib.hs b/testsuite/tests/th/TH_spliceDecl3_Lib.hs index 1b8d44e781..bc1c268197 100644 --- a/testsuite/tests/th/TH_spliceDecl3_Lib.hs +++ b/testsuite/tests/th/TH_spliceDecl3_Lib.hs @@ -4,8 +4,9 @@ where import Language.Haskell.TH rename' :: Dec -> Q [Dec] -rename' (DataD ctxt tyName tyvars cons derivs) = - return [DataD ctxt (stripMod tyName) tyvars (map renameCons cons) derivs] +rename' (DataD ctxt tyName tyvars ksig cons derivs) = + return [DataD ctxt (stripMod tyName) tyvars ksig + (map renameCons cons) derivs] where renameCons (NormalC conName tys) = NormalC (stripMod conName) tys -- diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 45ee2df13b..5a55b6f0da 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -369,6 +369,13 @@ 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('T10828a', normal, compile_fail, ['-v0']) +test('T10828b', normal, compile_fail, ['-v0']) test('T10891', normal, compile, ['-v0']) test('T10945', normal, compile_fail, ['-v0']) test('T10946', expect_broken(10946), compile, ['-v0']) |