From 2efb886cdedb44f05e2854aafd24808d199d7ff1 Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Tue, 24 Jan 2023 20:57:57 -0500
Subject: Fix two bugs in TypeData TH reification

This patch fixes two issues in the way that `type data` declarations were
reified with Template Haskell:

* `type data` data constructors are now properly reified using `DataConI`.
  This is accomplished with a special case in `reifyTyCon`. Fixes #22818.

* `type data` type constructors are now reified in `reifyTyCon` using
  `TypeDataD` instead of `DataD`. Fixes #22819.

(cherry picked from commit 2f1450521b816a7d287b72deba14d59b6ccfbdbf)
---
 compiler/GHC/Tc/Gen/Splice.hs    | 28 ++++++++++++++++++++++------
 testsuite/tests/th/T22818.hs     | 16 ++++++++++++++++
 testsuite/tests/th/T22818.stderr |  1 +
 testsuite/tests/th/T22819.hs     | 16 ++++++++++++++++
 testsuite/tests/th/T22819.stderr |  1 +
 testsuite/tests/th/all.T         |  2 ++
 6 files changed, 58 insertions(+), 6 deletions(-)
 create mode 100644 testsuite/tests/th/T22818.hs
 create mode 100644 testsuite/tests/th/T22818.stderr
 create mode 100644 testsuite/tests/th/T22819.hs
 create mode 100644 testsuite/tests/th/T22819.stderr

diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index e0d8dd956b..5cf69c0dfe 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -2065,11 +2065,7 @@ reifyThing (AGlobal (AnId id))
 
 reifyThing (AGlobal (ATyCon tc))   = reifyTyCon tc
 reifyThing (AGlobal (AConLike (RealDataCon dc)))
-  = do  { let name = dataConName dc
-        ; ty <- reifyType (idType (dataConWrapId dc))
-        ; return (TH.DataConI (reifyName name) ty
-                              (reifyName (dataConOrigTyCon dc)))
-        }
+  = mkDataConI dc
 
 reifyThing (AGlobal (AConLike (PatSynCon ps)))
   = do { let name = reifyName ps
@@ -2173,6 +2169,13 @@ reifyTyCon tc
                    (TH.TySynD (reifyName tc) tvs' rhs'))
        }
 
+  -- Special case for `type data` data constructors, which are reified as
+  -- `ATyCon`s rather than `ADataCon`s (#22818).
+  -- See Note [Type data declarations] in GHC.Rename.Module.
+  | Just dc <- isPromotedDataCon_maybe tc
+  , isTypeDataCon dc
+  = mkDataConI dc
+
   | otherwise
   = do  { cxt <- reifyCxt (tyConStupidTheta tc)
         ; let tvs      = tyConTyVars tc
@@ -2182,7 +2185,12 @@ reifyTyCon tc
         ; r_tvs <- reifyTyVars (tyConVisibleTyVars tc)
         ; let name = reifyName tc
               deriv = []        -- Don't know about deriving
-              decl | isNewTyCon tc =
+              decl | isTypeDataTyCon tc =
+                       -- `type data` declarations have a special `Dec`,
+                       -- separate from other `DataD`s. See
+                       -- [Type data declarations] in GHC.Rename.Module.
+                       TH.TypeDataD name r_tvs Nothing cons
+                   | isNewTyCon tc =
                        TH.NewtypeD cxt name r_tvs Nothing (head cons) deriv
                    | otherwise     =
                        TH.DataD    cxt name r_tvs Nothing       cons  deriv
@@ -2261,6 +2269,14 @@ reifyDataCon isGadtDataCon tys dc
           tv_bndrs'      = map (\(tv,fl) -> Bndr tv fl) (zip tvs' flags)
       in (subst', tv_bndrs')
 
+mkDataConI :: DataCon -> TcM TH.Info
+mkDataConI dc
+  = do  { let name = dataConName dc
+        ; ty <- reifyType (idType (dataConWrapId dc))
+        ; return (TH.DataConI (reifyName name) ty
+                              (reifyName (dataConOrigTyCon dc)))
+        }
+
 {-
 Note [Freshen reified GADT constructors' universal tyvars]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/testsuite/tests/th/T22818.hs b/testsuite/tests/th/T22818.hs
new file mode 100644
index 0000000000..40c89a8c1d
--- /dev/null
+++ b/testsuite/tests/th/T22818.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeData #-}
+module T22818 where
+
+import Language.Haskell.TH
+import System.IO
+
+type data T = MkT
+
+$(pure [])
+
+$(do i <- reify ''MkT
+     runIO $ do
+       hPutStrLn stderr $ pprint i
+       hFlush stderr
+     pure [])
diff --git a/testsuite/tests/th/T22818.stderr b/testsuite/tests/th/T22818.stderr
new file mode 100644
index 0000000000..ca1a04a45a
--- /dev/null
+++ b/testsuite/tests/th/T22818.stderr
@@ -0,0 +1 @@
+Constructor from T22818.T: T22818.MkT :: T22818.T
diff --git a/testsuite/tests/th/T22819.hs b/testsuite/tests/th/T22819.hs
new file mode 100644
index 0000000000..bd5385abad
--- /dev/null
+++ b/testsuite/tests/th/T22819.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeData #-}
+module T22818 where
+
+import Language.Haskell.TH
+import System.IO
+
+type data T = MkT
+
+$(pure [])
+
+$(do i <- reify ''T
+     runIO $ do
+       hPutStrLn stderr $ pprint i
+       hFlush stderr
+     pure [])
diff --git a/testsuite/tests/th/T22819.stderr b/testsuite/tests/th/T22819.stderr
new file mode 100644
index 0000000000..6389658d1e
--- /dev/null
+++ b/testsuite/tests/th/T22819.stderr
@@ -0,0 +1 @@
+type data T22818.T = T22818.MkT
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 971fb39056..2b30e752aa 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -556,4 +556,6 @@ test('T21920', normal, compile_and_run, [''])
 test('T21723', normal, compile_and_run, [''])
 test('T21942', normal, compile_and_run, [''])
 test('T22784', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('T22818', normal, compile, ['-v0'])
+test('T22819', normal, compile, ['-v0'])
 test('TH_fun_par', normal, compile, [''])
-- 
cgit v1.2.1