TemplateHaskell: reifyType (#16976)

13 files changed, 104 insertions, 1 deletions

diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index bcdc503e56..ba4f58752f 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -945,6 +945,7 @@ instance TH.Quasi TcM where
   qLookupName       = lookupName
   qReify            = reify
   qReifyFixity nm   = lookupThName nm >>= reifyFixity
+  qReifyType        = reifyTypeOfThing
   qReifyInstances   = reifyInstances
   qReifyRoles       = reifyRoles
   qReifyAnnotations = reifyAnnotations
@@ -1210,6 +1211,7 @@ handleTHMessage msg = case msg of
   LookupName b str -> wrapTHResult $ TH.qLookupName b str
   Reify n -> wrapTHResult $ TH.qReify n
   ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n
+  ReifyType n -> wrapTHResult $ TH.qReifyType n
   ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts
   ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n
   ReifyAnnotations lookup tyrep ->
@@ -2015,6 +2017,20 @@ reifyDecidedStrictness HsLazy     = TH.DecidedLazy
 reifyDecidedStrictness HsStrict   = TH.DecidedStrict
 reifyDecidedStrictness HsUnpack{} = TH.DecidedUnpack
 
+reifyTypeOfThing :: TH.Name -> TcM TH.Type
+reifyTypeOfThing th_name = do
+  thing <- getThing th_name
+  case thing of
+    AGlobal (AnId id) -> reifyType (idType id)
+    AGlobal (ATyCon tc) -> reifyKind (tyConKind tc)
+    AGlobal (AConLike (RealDataCon dc)) ->
+      reifyType (idType (dataConWrapId dc))
+    AGlobal (AConLike (PatSynCon ps)) ->
+      reifyPatSynType (patSynSig ps)
+    ATcId{tct_id = id} -> zonkTcType (idType id) >>= reifyType
+    ATyVar _ tctv -> zonkTcTyVar tctv >>= reifyType
+    _ -> failWithTc (text "No type or kind associated with" <+> ppr thing)
+
 ------------------------------
 lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget
 lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm)
diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index 319eebdfc0..d8c27b0702 100644
--- a/libraries/ghci/GHCi/Message.hs
+++ b/libraries/ghci/GHCi/Message.hs
@@ -242,6 +242,7 @@ data THMessage a where
   LookupName :: Bool -> String -> THMessage (THResult (Maybe TH.Name))
   Reify :: TH.Name -> THMessage (THResult TH.Info)
   ReifyFixity :: TH.Name -> THMessage (THResult (Maybe TH.Fixity))
+  ReifyType :: TH.Name -> THMessage (THResult TH.Type)
   ReifyInstances :: TH.Name -> [TH.Type] -> THMessage (THResult [TH.Dec])
   ReifyRoles :: TH.Name -> THMessage (THResult [TH.Role])
   ReifyAnnotations :: TH.AnnLookup -> TypeRep
@@ -295,7 +296,9 @@ getTHMessage = do
     18 -> return (THMsg RunTHDone)
     19 -> THMsg <$> AddModFinalizer <$> get
     20 -> THMsg <$> (AddForeignFilePath <$> get <*> get)
-    _  -> THMsg <$> AddCorePlugin <$> get
+    21 -> THMsg <$> AddCorePlugin <$> get
+    22 -> THMsg <$> ReifyType <$> get
+    n -> error ("getTHMessage: unknown message " ++ show n)
 
 putTHMessage :: THMessage a -> Put
 putTHMessage m = case m of
@@ -321,6 +324,7 @@ putTHMessage m = case m of
   AddModFinalizer a           -> putWord8 19 >> put a
   AddForeignFilePath lang a   -> putWord8 20 >> put lang >> put a
   AddCorePlugin a             -> putWord8 21 >> put a
+  ReifyType a                 -> putWord8 22 >> put a
 
 
 data EvalOpts = EvalOpts
diff --git a/libraries/ghci/GHCi/TH.hs b/libraries/ghci/GHCi/TH.hs
index 09df787db3..927376b53d 100644
--- a/libraries/ghci/GHCi/TH.hs
+++ b/libraries/ghci/GHCi/TH.hs
@@ -183,6 +183,7 @@ instance TH.Quasi GHCiQ where
   qLookupName isType occ = ghcCmd (LookupName isType occ)
   qReify name = ghcCmd (Reify name)
   qReifyFixity name = ghcCmd (ReifyFixity name)
+  qReifyType name = ghcCmd (ReifyType name)
   qReifyInstances name tys = ghcCmd (ReifyInstances name tys)
   qReifyRoles name = ghcCmd (ReifyRoles name)
 
diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs
index 213c70e58f..5b03b2649c 100644
--- a/libraries/template-haskell/Language/Haskell/TH.hs
+++ b/libraries/template-haskell/Language/Haskell/TH.hs
@@ -34,6 +34,8 @@ module Language.Haskell.TH(
         lookupValueName, -- :: String -> Q (Maybe Name)
         -- *** Fixity lookup
         reifyFixity,
+        -- *** Type lookup
+        reifyType,
         -- *** Instance lookup
         reifyInstances,
         isInstance,
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index f79a8e2b0c..72eadbff91 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -76,6 +76,7 @@ class (MonadIO m, Fail.MonadFail m) => Quasi m where
        -- True <=> type namespace, False <=> value namespace
   qReify          :: Name -> m Info
   qReifyFixity    :: Name -> m (Maybe Fixity)
+  qReifyType      :: Name -> m Type
   qReifyInstances :: Name -> [Type] -> m [Dec]
        -- Is (n tys) an instance?
        -- Returns list of matching instance Decs
@@ -132,6 +133,7 @@ instance Quasi IO where
   qLookupName _ _       = badIO "lookupName"
   qReify _              = badIO "reify"
   qReifyFixity _        = badIO "reifyFixity"
+  qReifyType _          = badIO "reifyFixity"
   qReifyInstances _ _   = badIO "reifyInstances"
   qReifyRoles _         = badIO "reifyRoles"
   qReifyAnnotations _   = badIO "reifyAnnotations"
@@ -429,6 +431,14 @@ example, if the function @foo@ has the fixity declaration @infixr 7 foo@, then
 reifyFixity :: Name -> Q (Maybe Fixity)
 reifyFixity nm = Q (qReifyFixity nm)
 
+{- | @reifyType nm@ attempts to find the type or kind of @nm@. For example,
+@reifyType 'not@   returns @Bool -> Bool@, and
+@reifyType ''Bool@ returns @Type@.
+This works even if there's no explicit signature and the type or kind is inferred.
+-}
+reifyType :: Name -> Q Type
+reifyType nm = Q (qReifyType nm)
+
 {- | @reifyInstances nm tys@ returns a list of visible instances of @nm tys@. That is,
 if @nm@ is the name of a type class, then all instances of this class at the types @tys@
 are returned. Alternatively, if @nm@ is the name of a data family or type family,
@@ -620,6 +630,7 @@ instance Quasi Q where
   qRecover            = recover
   qReify              = reify
   qReifyFixity        = reifyFixity
+  qReifyType          = reifyType
   qReifyInstances     = reifyInstances
   qReifyRoles         = reifyRoles
   qReifyAnnotations   = reifyAnnotations
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index a25292e29b..74b4bd2720 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -19,6 +19,9 @@
   * Make the `Lift` typeclass levity-polymorphic and add instances for unboxed
     tuples, unboxed sums, `Int#`, `Word#`, `Addr#`, `Float#`, and `Double#`.
 
+  * Introduce `reifyType` to reify the type or kind of a thing referenced by
+    `Name`.
+
 ## 2.15.0.0 *TBA*
 
   * In `Language.Haskell.TH.Syntax`, `DataInstD`, `NewTypeInstD`, `TySynEqn`,
diff --git a/testsuite/tests/th/T16976.hs b/testsuite/tests/th/T16976.hs
new file mode 100644
index 0000000000..4d2c889794
--- /dev/null
+++ b/testsuite/tests/th/T16976.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+
+module T16976 where
+
+import Language.Haskell.TH (reifyType, runIO)
+import Language.Haskell.TH.Ppr (ppr_sig)
+import Data.Foldable (for_)
+import System.IO (hPrint, stderr)
+
+data T s = MkT1 | MkT2
+
+aNumber = 5
+aString = "hi"
+
+pattern P = MkT1
+
+do  let names = [ 'aNumber, 'aString    -- local value declarations
+                , 'MkT1, 'MkT2          -- local data constructor declarations
+                , ''T                   -- local type constructor declarations
+                , 'P                    -- local pattern synonyms
+                , 'not, 'id             -- library value declarations
+                , 'Nothing              -- library data constructor declarations
+                , ''Maybe, ''Functor    -- library type constructor declarations
+                ]
+    for_ names $ \name -> do
+      t <- reifyType name
+      -- Why 'hPrint stderr' instead of 'print'? This is a workaround for the
+      -- testsuite driver quirk, otherwise the test fails in 'ext-interp' way.
+      runIO . hPrint stderr $ ppr_sig name t
+    return []
diff --git a/testsuite/tests/th/T16976.stderr b/testsuite/tests/th/T16976.stderr
new file mode 100644
index 0000000000..b711aa4de3
--- /dev/null
+++ b/testsuite/tests/th/T16976.stderr
@@ -0,0 +1,11 @@
+T16976.aNumber :: forall (p_0 :: *) . GHC.Num.Num p_0 => p_0
+T16976.aString :: [GHC.Types.Char]
+T16976.MkT1 :: forall (s_0 :: *) . T16976.T s_0
+T16976.MkT2 :: forall (s_0 :: *) . T16976.T s_0
+T16976.T :: * -> *
+T16976.P :: forall (s_0 :: *) . T16976.T s_0
+GHC.Classes.not :: GHC.Types.Bool -> GHC.Types.Bool
+GHC.Base.id :: forall (a_0 :: *) . a_0 -> a_0
+GHC.Maybe.Nothing :: forall (a_0 :: *) . GHC.Maybe.Maybe a_0
+GHC.Maybe.Maybe :: * -> *
+GHC.Base.Functor :: (* -> *) -> Constraint
diff --git a/testsuite/tests/th/T16976f.hs b/testsuite/tests/th/T16976f.hs
new file mode 100644
index 0000000000..90b8a1311f
--- /dev/null
+++ b/testsuite/tests/th/T16976f.hs
@@ -0,0 +1,6 @@
+module T16976f where
+
+import Language.Haskell.TH
+
+do  t <- reifyType (mkName "doesn'tExist")
+    return []
diff --git a/testsuite/tests/th/T16976f.stderr b/testsuite/tests/th/T16976f.stderr
new file mode 100644
index 0000000000..ec107f2f24
--- /dev/null
+++ b/testsuite/tests/th/T16976f.stderr
@@ -0,0 +1,2 @@
+
+T16976f.hs:5:1: error: ‘doesn'tExist’ is not in scope at a reify
diff --git a/testsuite/tests/th/T16976z.hs b/testsuite/tests/th/T16976z.hs
new file mode 100644
index 0000000000..2ba668f371
--- /dev/null
+++ b/testsuite/tests/th/T16976z.hs
@@ -0,0 +1,8 @@
+module T16976z where
+
+import Language.Haskell.TH
+
+do  let str :: String
+        str = "defined inside the splice"
+    t <- reifyType 'str
+    return []
diff --git a/testsuite/tests/th/T16976z.stderr b/testsuite/tests/th/T16976z.stderr
new file mode 100644
index 0000000000..2bcb642114
--- /dev/null
+++ b/testsuite/tests/th/T16976z.stderr
@@ -0,0 +1,5 @@
+
+T16976z.hs:7:20: error:
+    • Stage error: the non-top-level quoted name 'str
+      must be used at the same stage at which it is bound
+    • In the Template Haskell quotation 'str
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 02902c3956..2fc79b5484 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -485,3 +485,6 @@ test('T16895b', normal, compile_fail, [''])
 test('T16895c', normal, compile_fail, [''])
 test('T16895d', normal, compile_fail, [''])
 test('T16895e', normal, compile_fail, [''])
+test('T16976', normal, compile, [''])
+test('T16976f', normal, compile_fail, [''])
+test('T16976z', normal, compile_fail, [''])