Add `liftedTyped` to `Lift` class

Implements GHC proposal 43, adding a `liftTyped` method to the `Lift` typeclass.
This also adds some documentation to `TExp`, describing typed splices and their
advantages over their untyped counterparts.

Resolves #14671.

3 files changed, 66 insertions, 4 deletions

diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 3ff6393794..7bff489650 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -200,12 +200,53 @@ instance Applicative Q where
 -----------------------------------------------------
 
 type role TExp nominal   -- See Note [Role of TExp]
-newtype TExp a = TExp { unType :: Exp }
-
+newtype TExp a = TExp
+  { unType :: Exp -- ^ Underlying untyped Template Haskell expression
+  }
+-- ^ Represents an expression which has type @a@. Built on top of 'Exp', typed
+-- expressions allow for type-safe splicing via:
+--
+--   - typed quotes, written as @[|| ... ||]@ where @...@ is an expression; if
+--     that expression has type @a@, then the quotation has type
+--     @'Q' ('TExp' a)@
+--
+--   - typed splices inside of typed quotes, written as @$$(...)@ where @...@
+--     is an arbitrary expression of type @'Q' ('TExp' a)@
+--
+-- Traditional expression quotes and splices let us construct ill-typed
+-- expressions:
+--
+-- >>> fmap ppr $ runQ [| True == $( [| "foo" |] ) |]
+-- GHC.Types.True GHC.Classes.== "foo"
+-- >>> GHC.Types.True GHC.Classes.== "foo"
+-- <interactive> error:
+--     • Couldn't match expected type ‘Bool’ with actual type ‘[Char]’
+--     • In the second argument of ‘(==)’, namely ‘"foo"’
+--       In the expression: True == "foo"
+--       In an equation for ‘it’: it = True == "foo"
+--
+-- With typed expressions, the type error occurs when /constructing/ the
+-- Template Haskell expression:
+--
+-- >>> fmap ppr $ runQ [|| True == $$( [|| "foo" ||] ) ||]
+-- <interactive> error:
+--     • Couldn't match type ‘[Char]’ with ‘Bool’
+--       Expected type: Q (TExp Bool)
+--         Actual type: Q (TExp [Char])
+--     • In the Template Haskell quotation [|| "foo" ||]
+--       In the expression: [|| "foo" ||]
+--       In the Template Haskell splice $$([|| "foo" ||])
+
+-- | Discard the type annotation and produce a plain Template Haskell
+-- expression
 unTypeQ :: Q (TExp a) -> Q Exp
 unTypeQ m = do { TExp e <- m
                ; return e }
 
+-- | Annotate the Template Haskell expression with a type
+--
+-- This is unsafe because GHC cannot check for you that the expression
+-- really does have the type you claim it has.
 unsafeTExpCoerce :: Q Exp -> Q (TExp a)
 unsafeTExpCoerce m = do { e <- m
                         ; return (TExp e) }
@@ -635,8 +676,17 @@ class Lift t where
   -- | Turn a value into a Template Haskell expression, suitable for use in
   -- a splice.
   lift :: t -> Q Exp
-  default lift :: Data t => t -> Q Exp
-  lift = liftData
+  lift = unTypeQ . liftTyped
+
+  -- | Turn a value into a Template Haskell typed expression, suitable for use
+  -- in a typed splice.
+  --
+  -- @since 2.16.0.0
+  liftTyped :: t -> Q (TExp t)
+  liftTyped = unsafeTExpCoerce . lift
+
+  {-# MINIMAL lift | liftTyped #-}
+
 
 -- If you add any instances here, consider updating test th/TH_Lift
 instance Lift Integer where
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index b1444341d8..cfed120471 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -1,5 +1,10 @@
 # Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell)
 
+## 2.16.0.0 *TBA*
+
+  * Introduce a `liftTyped` method to the `Lift` class and set the default
+    implementations of `lift`/`liftTyped` to be in terms of each other.
+
 ## 2.15.0.0 *TBA*
 
   * In `Language.Haskell.TH.Syntax`, `DataInstD`, `NewTypeInstD`, `TySynEqn`,
diff --git a/testsuite/tests/deriving/should_compile/T14682.stderr b/testsuite/tests/deriving/should_compile/T14682.stderr
index ed44b3c2b1..75e9030bc7 100644
--- a/testsuite/tests/deriving/should_compile/T14682.stderr
+++ b/testsuite/tests/deriving/should_compile/T14682.stderr
@@ -98,6 +98,13 @@ GHC.Show.Show [T14682.Foo]
 
 
 ==================== Filling in method body ====================
+Language.Haskell.TH.Syntax.Lift [T14682.Foo]
+  Language.Haskell.TH.Syntax.liftTyped = Language.Haskell.TH.Syntax.$dmliftTyped
+                                           @(T14682.Foo)
+
+
+
+==================== Filling in method body ====================
 Data.Data.Data [T14682.Foo]
   Data.Data.dataCast1 = Data.Data.$dmdataCast1 @(T14682.Foo)