diff options
author | Ross Paterson <R.Paterson@city.ac.uk> | 2022-12-02 20:27:23 +0000 |
---|---|---|
committer | Ross Paterson <R.Paterson@city.ac.uk> | 2022-12-03 10:32:45 +0000 |
commit | 4251226448f34403b07822f3017845c4855f4dea (patch) | |
tree | 04bd631300945a5f7a3477a93fee58f2140d3a20 | |
parent | c189b831c74a550ddb3b94cf9b9f8922856b6990 (diff) | |
download | haskell-4251226448f34403b07822f3017845c4855f4dea.tar.gz |
Handle type data declarations in Template Haskell quotations and splices (fixes #22500)
This adds a TypeDataD constructor to the Template Haskell Dec type,
and ensures that the constructors it contains go in the TyCls namespace.
-rw-r--r-- | compiler/GHC/Builtin/Names/TH.hs | 10 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Quote.hs | 15 | ||||
-rw-r--r-- | compiler/GHC/Rename/Module.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/Splice.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/ThToHs.hs | 115 | ||||
-rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Lib.hs | 14 | ||||
-rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs | 23 | ||||
-rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Ppr.hs | 6 | ||||
-rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Syntax.hs | 3 | ||||
-rw-r--r-- | libraries/template-haskell/changelog.md | 3 | ||||
-rw-r--r-- | testsuite/tests/type-data/should_compile/TD_TH_splice.hs | 18 | ||||
-rw-r--r-- | testsuite/tests/type-data/should_compile/all.T | 1 | ||||
-rw-r--r-- | testsuite/tests/type-data/should_run/T22500.hs | 9 | ||||
-rw-r--r-- | testsuite/tests/type-data/should_run/T22500.stdout | 3 | ||||
-rw-r--r-- | testsuite/tests/type-data/should_run/all.T | 1 |
15 files changed, 172 insertions, 55 deletions
diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs index 3908f5091c..86814fb263 100644 --- a/compiler/GHC/Builtin/Names/TH.hs +++ b/compiler/GHC/Builtin/Names/TH.hs @@ -69,7 +69,7 @@ templateHaskellNames = [ -- Stmt bindSName, letSName, noBindSName, parSName, recSName, -- Dec - funDName, valDName, dataDName, newtypeDName, tySynDName, + funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName, classDName, instanceWithOverlapDName, standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName, pragInlDName, pragOpaqueDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, @@ -354,7 +354,7 @@ parSName = libFun (fsLit "parS") parSIdKey recSName = libFun (fsLit "recS") recSIdKey -- data Dec = ... -funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, +funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName, classDName, instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName, pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName, defaultDName, @@ -366,6 +366,7 @@ funDName = libFun (fsLit "funD") valDName = libFun (fsLit "valD") valDIdKey dataDName = libFun (fsLit "dataD") dataDIdKey newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey +typeDataDName = libFun (fsLit "typeDataD") typeDataDIdKey tySynDName = libFun (fsLit "tySynD") tySynDIdKey classDName = libFun (fsLit "classD") classDIdKey instanceWithOverlapDName = libFun (fsLit "instanceWithOverlapD") instanceWithOverlapDIdKey @@ -888,7 +889,7 @@ funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey, newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey, infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey, patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey, - kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey :: Unique + kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey, typeDataDIdKey :: Unique funDIdKey = mkPreludeMiscIdUnique 320 valDIdKey = mkPreludeMiscIdUnique 321 dataDIdKey = mkPreludeMiscIdUnique 322 @@ -923,7 +924,8 @@ pragCompleteDIdKey = mkPreludeMiscIdUnique 350 implicitParamBindDIdKey = mkPreludeMiscIdUnique 351 kiSigDIdKey = mkPreludeMiscIdUnique 352 defaultDIdKey = mkPreludeMiscIdUnique 353 -pragOpaqueDIdKey = mkPreludeMiscIdUnique 354 +pragOpaqueDIdKey = mkPreludeMiscIdUnique 354 +typeDataDIdKey = mkPreludeMiscIdUnique 355 -- type Cxt = ... cxtIdKey :: Unique diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 27dd193499..e4e8473d71 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -528,10 +528,10 @@ repDataDefn tc opts ; ksig' <- repMaybeLTy ksig ; repNewtype cxt1 tc opts ksig' con' derivs1 } - DataTypeCons _ cons -> do { ksig' <- repMaybeLTy ksig + DataTypeCons type_data cons -> do { ksig' <- repMaybeLTy ksig ; consL <- mapM repC cons ; cons1 <- coreListM conTyConName consL - ; repData cxt1 tc opts ksig' cons1 + ; repData type_data cxt1 tc opts ksig' cons1 derivs1 } } @@ -2528,14 +2528,17 @@ repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds] repFun :: Core TH.Name -> Core [(M TH.Clause)] -> MetaM (Core (M TH.Dec)) repFun (MkC nm) (MkC b) = rep2 funDName [nm, b] -repData :: Core (M TH.Cxt) -> Core TH.Name +repData :: Bool -- ^ @True@ for a @type data@ declaration. + -- See Note [Type data declarations] in GHC.Rename.Module + -> Core (M TH.Cxt) -> Core TH.Name -> Either (Core [(M (TH.TyVarBndr ()))]) (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type)) -> Core (Maybe (M TH.Kind)) -> Core [(M TH.Con)] -> Core [M TH.DerivClause] -> MetaM (Core (M TH.Dec)) -repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs) - = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs] -repData (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons) +repData type_data (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs) + | type_data = rep2 typeDataDName [nm, tvs, ksig, cons] + | otherwise = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs] +repData _ (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons) (MkC derivs) = rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs] diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index b0bb1cbd68..537e161e42 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -2130,6 +2130,10 @@ The main parts of the implementation are: of the `IfDataTyCon` constructor of `IfaceConDecls` by GHC.Iface.Make.tyConToIfaceDecl. +* The Template Haskell `Dec` type has an constructor `TypeDataD` for + `type data` declarations. When these are converted back to Hs types + in a splice, the constructors are placed in the TcCls namespace. + -} warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn) diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index cde7c305c1..6ba304be16 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -2681,7 +2681,7 @@ reify_tc_app tc tys | tc `hasKey` heqTyConKey = TH.EqualityT | tc `hasKey` eqPrimTyConKey = TH.EqualityT | tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon) - | isPromotedDataCon tc = TH.PromotedT (reifyName tc) + | isDataKindsPromotedDataCon tc = TH.PromotedT (reifyName tc) | otherwise = TH.ConT (reifyName tc) -- See Note [When does a tycon application need an explicit kind diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 0a1fb615ec..bc6cbe0da1 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -270,36 +270,12 @@ cvtDec (TySynD tc tvs rhs) , tcdRhs = rhs' } } cvtDec (DataD ctxt tc tvs ksig constrs derivs) - = do { let isGadtCon (GadtC _ _ _) = True - isGadtCon (RecGadtC _ _ _) = True - isGadtCon (ForallC _ _ c) = isGadtCon c - isGadtCon _ = False - isGadtDecl = all isGadtCon constrs - isH98Decl = all (not . isGadtCon) constrs - ; unless (isGadtDecl || isH98Decl) - (failWith CannotMixGADTConsWith98Cons) - ; unless (isNothing ksig || isGadtDecl) - (failWith KindSigsOnlyAllowedOnGADTs) - ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs - ; ksig' <- cvtKind `traverse` ksig - ; cons' <- mapM cvtConstr constrs - ; derivs' <- cvtDerivs derivs - ; let defn = HsDataDefn { dd_ext = noExtField - , dd_cType = Nothing - , dd_ctxt = mkHsContextMaybe ctxt' - , dd_kindSig = ksig' - , dd_cons = DataTypeCons False cons' - , dd_derivs = derivs' } - ; returnJustLA $ TyClD noExtField $ - DataDecl { tcdDExt = noAnn - , tcdLName = tc', tcdTyVars = tvs' - , tcdFixity = Prefix - , tcdDataDefn = defn } } + = cvtDataDec ctxt tc tvs ksig constrs 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 + ; con' <- cvtConstr cNameN constr ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ext = noExtField , dd_cType = Nothing @@ -313,6 +289,9 @@ cvtDec (NewtypeD ctxt tc tvs ksig constr derivs) , tcdFixity = Prefix , tcdDataDefn = defn } } +cvtDec (TypeDataD tc tvs ksig constrs) + = cvtTypeDataDec tc tvs ksig constrs + cvtDec (ClassD ctxt cl tvs fds decs) = do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs ; fds' <- mapM cvt_fundep fds @@ -368,7 +347,7 @@ cvtDec (DataFamilyD tc tvs kind) cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs) = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys ; ksig' <- cvtKind `traverse` ksig - ; cons' <- mapM cvtConstr constrs + ; cons' <- mapM (cvtConstr cNameN) constrs ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ext = noExtField , dd_cType = Nothing @@ -390,7 +369,7 @@ cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs) cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs) = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys ; ksig' <- cvtKind `traverse` ksig - ; con' <- cvtConstr constr + ; con' <- cvtConstr cNameN constr ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ext = noExtField , dd_cType = Nothing @@ -484,6 +463,59 @@ cvtDec (TH.PatSynSigD nm ty) cvtDec (TH.ImplicitParamBindD _ _) = failWith InvalidImplicitParamBinding +-- Convert a @data@ declaration. +cvtDataDec :: TH.Cxt -> TH.Name -> [TH.TyVarBndr ()] + -> Maybe TH.Kind -> [TH.Con] -> [TH.DerivClause] + -> CvtM (Maybe (LHsDecl GhcPs)) +cvtDataDec = cvtGenDataDec False + +-- Convert a @type data@ declaration. +-- These have neither contexts nor derived clauses. +-- See Note [Type data declarations] in GHC.Rename.Module. +cvtTypeDataDec :: TH.Name -> [TH.TyVarBndr ()] -> Maybe TH.Kind -> [TH.Con] + -> CvtM (Maybe (LHsDecl GhcPs)) +cvtTypeDataDec tc tvs ksig constrs + = cvtGenDataDec True [] tc tvs ksig constrs [] + +-- Convert a @data@ or @type data@ declaration (flagged by the Bool arg). +-- See Note [Type data declarations] in GHC.Rename.Module. +cvtGenDataDec :: Bool -> TH.Cxt -> TH.Name -> [TH.TyVarBndr ()] + -> Maybe TH.Kind -> [TH.Con] -> [TH.DerivClause] + -> CvtM (Maybe (LHsDecl GhcPs)) +cvtGenDataDec type_data 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 + -- A constructor in a @data@ or @newtype@ declaration is + -- a data constructor. A constructor in a @type data@ + -- declaration is a type constructor. + -- See Note [Type data declarations] in GHC.Rename.Module. + con_name + | type_data = tconNameN + | otherwise = cNameN + ; unless (isGadtDecl || isH98Decl) + (failWith CannotMixGADTConsWith98Cons) + ; unless (isNothing ksig || isGadtDecl) + (failWith KindSigsOnlyAllowedOnGADTs) + ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs + ; ksig' <- cvtKind `traverse` ksig + ; cons' <- mapM (cvtConstr con_name) constrs + ; derivs' <- cvtDerivs derivs + ; let defn = HsDataDefn { dd_ext = noExtField + , dd_cType = Nothing + , dd_ctxt = mkHsContextMaybe ctxt' + , dd_kindSig = ksig' + , dd_cons = DataTypeCons type_data cons' + , dd_derivs = derivs' } + ; returnJustLA $ TyClD noExtField $ + DataDecl { tcdDExt = noAnn + , tcdLName = tc', tcdTyVars = tvs' + , tcdFixity = Prefix + , tcdDataDefn = defn } } + ---------------- cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs) cvtTySynEqn (TySynEqn mb_bndrs lhs rhs) @@ -617,30 +649,31 @@ is_ip_bind decl = Right decl -- Data types --------------------------------------------------- -cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs) +cvtConstr :: (TH.Name -> CvtM (LocatedN RdrName)) -- ^ convert constructor name + -> TH.Con -> CvtM (LConDecl GhcPs) -cvtConstr (NormalC c strtys) - = do { c' <- cNameN c +cvtConstr con_name (NormalC c strtys) + = do { c' <- con_name c ; tys' <- mapM cvt_arg strtys ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing (PrefixCon noTypeArgs (map hsLinear tys')) } -cvtConstr (RecC c varstrtys) - = do { c' <- cNameN c +cvtConstr con_name (RecC c varstrtys) + = do { c' <- con_name c ; args' <- mapM cvt_id_arg varstrtys ; con_decl <- wrapParLA (mkConDeclH98 noAnn c' Nothing Nothing . RecCon) args' ; returnLA con_decl } -cvtConstr (InfixC st1 c st2) - = do { c' <- cNameN c +cvtConstr con_name (InfixC st1 c st2) + = do { c' <- con_name c ; st1' <- cvt_arg st1 ; st2' <- cvt_arg st2 ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing (InfixCon (hsLinear st1') (hsLinear st2')) } -cvtConstr (ForallC tvs ctxt con) +cvtConstr con_name (ForallC tvs ctxt con) = do { tvs' <- cvtTvs tvs ; ctxt' <- cvtContext funPrec ctxt - ; L _ con' <- cvtConstr con + ; L _ con' <- cvtConstr con_name con ; returnLA $ add_forall tvs' ctxt' con' } where add_cxt lcxt Nothing = mkHsContextMaybe lcxt @@ -668,18 +701,18 @@ cvtConstr (ForallC tvs ctxt con) where all_tvs = tvs' ++ ex_tvs -cvtConstr (GadtC c strtys ty) = case nonEmpty c of +cvtConstr con_name (GadtC c strtys ty) = case nonEmpty c of Nothing -> failWith GadtNoCons Just c -> do - { c' <- mapM cNameN c + { c' <- mapM con_name c ; args <- mapM cvt_arg strtys ; ty' <- cvtType ty ; mk_gadt_decl c' (PrefixConGADT $ map hsLinear args) ty'} -cvtConstr (RecGadtC c varstrtys ty) = case nonEmpty c of +cvtConstr con_name (RecGadtC c varstrtys ty) = case nonEmpty c of Nothing -> failWith RecGadtNoCons Just c -> do - { c' <- mapM cNameN c + { c' <- mapM con_name c ; ty' <- cvtType ty ; rec_flds <- mapM cvt_id_arg varstrtys ; lrec_flds <- returnLA rec_flds diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index e052818c0b..b52de5b0d3 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -86,7 +86,7 @@ module Language.Haskell.TH.Lib ( -- *** Top Level Declarations -- **** Data - valD, funD, tySynD, dataD, newtypeD, + valD, funD, tySynD, dataD, newtypeD, typeDataD, derivClause, DerivClause(..), stockStrategy, anyclassStrategy, newtypeStrategy, viaStrategy, DerivStrategy(..), @@ -131,8 +131,8 @@ module Language.Haskell.TH.Lib ( thisModule, -- ** Documentation - withDecDoc, withDecsDoc, funD_doc, dataD_doc, newtypeD_doc, dataInstD_doc, - newtypeInstD_doc, patSynD_doc + withDecDoc, withDecsDoc, funD_doc, dataD_doc, newtypeD_doc, + typeDataD_doc, dataInstD_doc, newtypeInstD_doc, patSynD_doc ) where @@ -140,6 +140,7 @@ import Language.Haskell.TH.Lib.Internal hiding ( tySynD , dataD , newtypeD + , typeDataD , classD , pragRuleD , dataInstD @@ -212,6 +213,13 @@ newtypeD ctxt tc tvs ksig con derivs = derivs1 <- sequenceA derivs return (NewtypeD ctxt1 tc tvs ksig con1 derivs1) +typeDataD :: Quote m => Name -> [TyVarBndr ()] -> Maybe Kind -> [m Con] + -> m Dec +typeDataD tc tvs ksig cons = + do + cons1 <- sequenceA cons + return (TypeDataD tc tvs ksig cons1) + classD :: Quote m => m Cxt -> Name -> [TyVarBndr ()] -> [FunDep] -> [m Dec] -> m Dec classD ctxt cls tvs fds decs = do diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs index e95a449e1d..35bca47d25 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs @@ -441,6 +441,15 @@ newtypeD ctxt tc tvs ksig con derivs = derivs1 <- sequenceA derivs pure (NewtypeD ctxt1 tc tvs1 ksig1 con1 derivs1) +typeDataD :: Quote m => Name -> [m (TyVarBndr ())] -> Maybe (m Kind) -> [m Con] + -> m Dec +typeDataD tc tvs ksig cons = + do + tvs1 <- sequenceA tvs + ksig1 <- sequenceA ksig + cons1 <- sequenceA cons + pure (TypeDataD tc tvs1 ksig1 cons1) + classD :: Quote m => m Cxt -> Name -> [m (TyVarBndr ())] -> [FunDep] -> [m Dec] -> m Dec classD ctxt cls tvs fds decs = do @@ -1033,6 +1042,7 @@ withDecDoc doc dec = do doc_loc (ValD (VarP n) _ _) = Just $ DeclDoc n doc_loc (DataD _ n _ _ _ _) = Just $ DeclDoc n doc_loc (NewtypeD _ n _ _ _ _) = Just $ DeclDoc n + doc_loc (TypeDataD n _ _ _) = Just $ DeclDoc n doc_loc (TySynD n _ _) = Just $ DeclDoc n doc_loc (ClassD _ n _ _ _) = Just $ DeclDoc n doc_loc (SigD n _) = Just $ DeclDoc n @@ -1108,6 +1118,19 @@ newtypeD_doc ctxt tc tvs ksig con_with_docs@(con, _, _) derivs mdoc = do let dec = newtypeD ctxt tc tvs ksig con derivs maybe dec (flip withDecDoc dec) mdoc +-- | Variant of 'typeDataD' that attaches Haddock documentation. +typeDataD_doc :: Name -> [Q (TyVarBndr ())] -> Maybe (Q Kind) + -> [(Q Con, Maybe String, [Maybe String])] + -- ^ List of constructors, documentation for the constructor, and + -- documentation for the arguments + -> Maybe String + -- ^ Documentation to attach to the data declaration + -> Q Dec +typeDataD_doc tc tvs ksig cons_with_docs mdoc = do + qAddModFinalizer $ mapM_ docCons cons_with_docs + let dec = typeDataD tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs) + maybe dec (flip withDecDoc dec) mdoc + -- | Variant of 'dataInstD' that attaches Haddock documentation. dataInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type -> Maybe (Q Kind) -> [(Q Con, Maybe String, [Maybe String])] diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index 585b9bb295..cedb974976 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -399,6 +399,8 @@ ppr_dec _ (DataD ctxt t xs ksig cs decs) = ppr_data empty ctxt (Just t) (hsep (map ppr xs)) ksig cs decs ppr_dec _ (NewtypeD ctxt t xs ksig c decs) = ppr_newtype empty ctxt (Just t) (sep (map ppr xs)) ksig c decs +ppr_dec _ (TypeDataD t xs ksig cs) + = ppr_type_data empty [] (Just t) (hsep (map ppr xs)) ksig cs [] ppr_dec _ (ClassD ctxt c xs fds ds) = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds $$ where_clause ds @@ -495,6 +497,10 @@ ppr_newtype :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> Con -> [DerivCla -> Doc ppr_newtype maybeInst ctxt t argsDoc ksig c decs = ppr_typedef "newtype" maybeInst ctxt t argsDoc ksig [c] decs +ppr_type_data :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] + -> Doc +ppr_type_data = ppr_typedef "type data" + ppr_typedef :: String -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc ppr_typedef data_or_newtype maybeInst ctxt t argsDoc ksig cs decs = sep [text data_or_newtype <+> maybeInst diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index aae6ecdbb1..30958c5cbe 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -2399,6 +2399,9 @@ data Dec Con [DerivClause] -- ^ @{ newtype Cxt x => T x = A (B x) -- deriving (Z,W Q) -- deriving stock Eq }@ + | TypeDataD Name [TyVarBndr ()] + (Maybe Kind) -- Kind signature (allowed only for GADTs) + [Con] -- ^ @{ type data T x = A x | B (T x) }@ | TySynD Name [TyVarBndr ()] Type -- ^ @{ type T x = (x,x) }@ | ClassD Cxt Name [TyVarBndr ()] [FunDep] [Dec] -- ^ @{ class Eq a => Ord a where ds }@ diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md index 9cff6411cb..bf63b6e689 100644 --- a/libraries/template-haskell/changelog.md +++ b/libraries/template-haskell/changelog.md @@ -5,6 +5,9 @@ * The `Ppr.pprInfixT` function has gained a `Precedence` argument. * The values of named precedence levels like `Ppr.appPrec` have changed. + * Add `TypeDataD` constructor to the `Dec` type for `type data` + declarations (GHC proposal #106). + ## 2.19.0.0 * Add `DefaultD` constructor to support Haskell `default` declarations. diff --git a/testsuite/tests/type-data/should_compile/TD_TH_splice.hs b/testsuite/tests/type-data/should_compile/TD_TH_splice.hs new file mode 100644 index 0000000000..78b5495858 --- /dev/null +++ b/testsuite/tests/type-data/should_compile/TD_TH_splice.hs @@ -0,0 +1,18 @@ +-- Check that splicing in a quoted declaration has the same effect as +-- giving the declaration directly. +{-# LANGUAGE TemplateHaskell, TypeData, GADTs #-} + +module TD_TH_splice where + +import Data.Kind (Type) + +-- splice should be equivalent to giving the declaration directly +$( [d| type data Nat = Zero | Succ Nat |] ) + +data Vec :: Nat -> Type -> Type where + VNil :: Vec Zero a + VCons :: a -> Vec n a -> Vec (Succ n) a + +instance Functor (Vec n) where + fmap _ VNil = VNil + fmap f (VCons x xs) = VCons (f x) (fmap f xs) diff --git a/testsuite/tests/type-data/should_compile/all.T b/testsuite/tests/type-data/should_compile/all.T index b5e9810b00..7042676613 100644 --- a/testsuite/tests/type-data/should_compile/all.T +++ b/testsuite/tests/type-data/should_compile/all.T @@ -3,4 +3,5 @@ test('TDExistential', normal, compile, ['']) test('TDGADT', normal, compile, ['']) test('TDGoodConsConstraints', normal, compile, ['']) test('TDVector', normal, compile, ['']) +test('TD_TH_splice', normal, compile, ['']) test('T22315a', [extra_files(['T22315a/'])], multimod_compile, ['T22315a.Lib T22315a.Main', '-v0']) diff --git a/testsuite/tests/type-data/should_run/T22500.hs b/testsuite/tests/type-data/should_run/T22500.hs new file mode 100644 index 0000000000..471b6b1d2a --- /dev/null +++ b/testsuite/tests/type-data/should_run/T22500.hs @@ -0,0 +1,9 @@ +-- Check that a quoted data type declaration is printed correctly +{-# LANGUAGE TemplateHaskellQuotes, TypeData #-} + +module Main where + +import Language.Haskell.TH +import Language.Haskell.TH.Ppr + +main = putStrLn . pprint =<< runQ [d| type data Nat = Zero | Succ Nat |] diff --git a/testsuite/tests/type-data/should_run/T22500.stdout b/testsuite/tests/type-data/should_run/T22500.stdout new file mode 100644 index 0000000000..eadaae2eeb --- /dev/null +++ b/testsuite/tests/type-data/should_run/T22500.stdout @@ -0,0 +1,3 @@ +type data Nat_0 + = Zero_1 + | Succ_2 Nat_0 diff --git a/testsuite/tests/type-data/should_run/all.T b/testsuite/tests/type-data/should_run/all.T index f1faf7796e..cc1bb25df1 100644 --- a/testsuite/tests/type-data/should_run/all.T +++ b/testsuite/tests/type-data/should_run/all.T @@ -1,2 +1,3 @@ test('T22332a', exit_code(1), compile_and_run, ['']) test('T22315b', extra_files(['T22315b.hs']), ghci_script, ['T22315b.script']) +test('T22500', normal, compile_and_run, ['']) |