summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRyan Scott <ryan.gl.scott@gmail.com>2023-01-24 20:57:57 -0500
committerMarge Bot <ben+marge-bot@smart-cactus.org>2023-01-30 21:19:56 -0500
commit2f1450521b816a7d287b72deba14d59b6ccfbdbf (patch)
treede16ae0d22fe31fae4f6079dacc1caeaba9db930
parent20598ef6d9e26e2e0af9ac42a42e7be00d7cc4f3 (diff)
downloadhaskell-2f1450521b816a7d287b72deba14d59b6ccfbdbf.tar.gz
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.
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs28
-rw-r--r--testsuite/tests/th/T22818.hs16
-rw-r--r--testsuite/tests/th/T22818.stderr1
-rw-r--r--testsuite/tests/th/T22819.hs16
-rw-r--r--testsuite/tests/th/T22819.stderr1
-rw-r--r--testsuite/tests/th/all.T2
6 files changed, 58 insertions, 6 deletions
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 239a55ee6e..e1a91ad495 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, [''])