summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/typecheck/TcSplice.hs16
-rw-r--r--libraries/ghci/GHCi/Message.hs6
-rw-r--r--libraries/ghci/GHCi/TH.hs1
-rw-r--r--libraries/template-haskell/Language/Haskell/TH.hs2
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Syntax.hs11
-rw-r--r--libraries/template-haskell/changelog.md3
-rw-r--r--testsuite/tests/th/T16976.hs31
-rw-r--r--testsuite/tests/th/T16976.stderr11
-rw-r--r--testsuite/tests/th/T16976f.hs6
-rw-r--r--testsuite/tests/th/T16976f.stderr2
-rw-r--r--testsuite/tests/th/T16976z.hs8
-rw-r--r--testsuite/tests/th/T16976z.stderr5
-rw-r--r--testsuite/tests/th/all.T3
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, [''])
View Lorry Controller Status