Make CodeQ and TExpQ levity polymorphic

The patch is quite straightforward. The only tricky part is that
`Language.Haskell.TH.Lib.Internal` now must be `Trustworthy` instead
of `Safe` due to the `GHC.Exts` import (in order to import `TYPE`).

Since `CodeQ` has yet to appear in any released version of
`template-haskell`, I didn't bother mentioning the change to `CodeQ`
in the `template-haskell` release notes.

Fixes #18521.

5 files changed, 36 insertions, 3 deletions

diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
index cb19882a97..fa38e6a933 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE Trustworthy #-}
 
 -- |
 -- Language.Haskell.TH.Lib.Internal exposes some additional functionality that
@@ -19,19 +20,31 @@ module Language.Haskell.TH.Lib.Internal where
 import Language.Haskell.TH.Syntax hiding (Role, InjectivityAnn)
 import qualified Language.Haskell.TH.Syntax as TH
 import Control.Applicative(liftA, liftA2)
+import qualified Data.Kind as Kind (Type)
 import Data.Word( Word8 )
+import GHC.Exts (TYPE)
 import Prelude
 
 ----------------------------------------------------------
 -- * Type synonyms
 ----------------------------------------------------------
 
+-- Since GHC 8.8 is currently the minimum boot compiler version that we must
+-- support, we must use inline kind signatures to make TExpQ and CodeQ
+-- levity polymorphic. When we drop support for GHC 8.8, we can instead use
+-- standalone kind signatures, which are provided as comments.
+
+-- | Levity-polymorphic since /template-haskell-2.17.0.0/.
+-- type TExpQ :: TYPE r -> Kind.Type
+type TExpQ (a :: TYPE r) = Q (TExp a)
+
+-- type CodeQ :: TYPE r -> Kind.Type
+type CodeQ = Code Q :: (TYPE r -> Kind.Type)
+
 type InfoQ               = Q Info
 type PatQ                = Q Pat
 type FieldPatQ           = Q FieldPat
 type ExpQ                = Q Exp
-type TExpQ a             = Q (TExp a)
-type CodeQ               = Code Q
 type DecQ                = Q Dec
 type DecsQ               = Q [Dec]
 type Decs                = [Dec] -- Defined as it is more convenient to wire-in
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index dac97c641f..9c47b6cfdd 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -341,6 +341,8 @@ newtype TExp (a :: TYPE (r :: RuntimeRep)) = TExp
 --     • In the Template Haskell quotation [|| "foo" ||]
 --       In the expression: [|| "foo" ||]
 --       In the Template Haskell splice $$([|| "foo" ||])
+--
+-- Levity-polymorphic since /template-haskell-2.16.0.0/.
 
 -- | Discard the type annotation and produce a plain Template Haskell
 -- expression
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index eb72b11858..8cd88b5ccc 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -32,6 +32,8 @@
   * Add support for QualifiedDo. The data constructors `DoE` and `MDoE` got a new
     `Maybe ModName` argument to describe the qualifier of do blocks.
 
+  * The argument to `TExpQ` can now be levity polymorphic.
+
 ## 2.16.0.0 *TBA*
 
   * Add support for tuple sections. (#15843) The type signatures of `TupE` and
diff --git a/testsuite/tests/quotes/T18521.hs b/testsuite/tests/quotes/T18521.hs
new file mode 100644
index 0000000000..9b5965ae3b
--- /dev/null
+++ b/testsuite/tests/quotes/T18521.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
+module T18521 where
+
+import GHC.Exts (Int#)
+import Language.Haskell.TH
+
+a :: Code Q Int#
+a = [|| 42# ||]
+
+b :: CodeQ Int#
+b = a
+
+c :: TExpQ Int#
+c = examineCode a
diff --git a/testsuite/tests/quotes/all.T b/testsuite/tests/quotes/all.T
index 3f20d2982c..b0e5274761 100644
--- a/testsuite/tests/quotes/all.T
+++ b/testsuite/tests/quotes/all.T
@@ -19,6 +19,7 @@ test('T16384', req_th, compile, [''])
 test('T17857', normal, compile, [''])
 test('T18103', normal, compile, [''])
 test('T18263', normal, compile_fail, [''])
+test('T18521', normal, compile, [''])
 
 test('TH_tf2', normal, compile, ['-v0'])
 test('TH_ppr1', normal, compile_and_run, [''])