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 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, [''])