[Git][ghc/ghc][master] Handle type data declarations in Template Haskell quotations and splices (fixes #22500)
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Dec 5 10:18:37 UTC 2022
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
42512264 by Ross Paterson at 2022-12-03T10:32:45+00:00
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.
- - - - -
15 changed files:
- compiler/GHC/Builtin/Names/TH.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/ThToHs.hs
- libraries/template-haskell/Language/Haskell/TH/Lib.hs
- libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
- libraries/template-haskell/Language/Haskell/TH/Ppr.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- libraries/template-haskell/changelog.md
- + testsuite/tests/type-data/should_compile/TD_TH_splice.hs
- testsuite/tests/type-data/should_compile/all.T
- + testsuite/tests/type-data/should_run/T22500.hs
- + testsuite/tests/type-data/should_run/T22500.stdout
- testsuite/tests/type-data/should_run/all.T
Changes:
=====================================
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
=====================================
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]
=====================================
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)
=====================================
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
=====================================
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
=====================================
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
=====================================
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])]
=====================================
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
=====================================
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 }@
=====================================
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.
=====================================
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)
=====================================
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'])
=====================================
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 |]
=====================================
testsuite/tests/type-data/should_run/T22500.stdout
=====================================
@@ -0,0 +1,3 @@
+type data Nat_0
+ = Zero_1
+ | Succ_2 Nat_0
=====================================
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, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4251226448f34403b07822f3017845c4855f4dea
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4251226448f34403b07822f3017845c4855f4dea
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221205/50049103/attachment-0001.html>
More information about the ghc-commits
mailing list