[Git][ghc/ghc][master] Fix two bugs in TypeData TH reification

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
2f145052 by Ryan Scott at 2023-01-30T21:19:56-05:00
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.

- - - - -


6 changed files:

- compiler/GHC/Tc/Gen/Splice.hs
- + testsuite/tests/th/T22818.hs
- + testsuite/tests/th/T22818.stderr
- + testsuite/tests/th/T22819.hs
- + testsuite/tests/th/T22819.stderr
- testsuite/tests/th/all.T


Changes:

=====================================
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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


=====================================
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 [])


=====================================
testsuite/tests/th/T22818.stderr
=====================================
@@ -0,0 +1 @@
+Constructor from T22818.T: T22818.MkT :: T22818.T


=====================================
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 [])


=====================================
testsuite/tests/th/T22819.stderr
=====================================
@@ -0,0 +1 @@
+type data T22818.T = T22818.MkT


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



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2f1450521b816a7d287b72deba14d59b6ccfbdbf

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2f1450521b816a7d287b72deba14d59b6ccfbdbf
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/20230130/2fec3ac8/attachment-0001.html>