TH: make `Lift` and `TExp` levity-polymorphic

Besides the obvious benefits of being able to manipulate `TExp`'s of
unboxed types, this also simplified `-XDeriveLift` all while making
it more capable.

  * `ghc-prim` is explicitly depended upon by `template-haskell`

  * The following TH things are parametrized over `RuntimeRep`:

      - `TExp(..)`
      - `unTypeQ`
      - `unsafeTExpCoerce`
      - `Lift(..)`

  * The following instances have been added to `Lift`:

      - `Int#`, `Word#`, `Float#`, `Double#`, `Char#`, `Addr#`
      - unboxed tuples of lifted types up to arity 7
      - unboxed sums of lifted types up to arity 7

    Ideally we would have levity-polymorphic _instances_ of unboxed
    tuples and sums.

  * The code generated by `-XDeriveLift` uses expression quotes
    instead of generating large amounts of TH code and having
    special hard-coded cases for some unboxed types.

15 files changed, 306 insertions, 150 deletions

diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs
index 140b3df6f8..58f9af770d 100644
--- a/compiler/prelude/THNames.hs
+++ b/compiler/prelude/THNames.hs
@@ -27,7 +27,7 @@ templateHaskellNames :: [Name]
 -- Should stay in sync with the import list of DsMeta
 
 templateHaskellNames = [
-    returnQName, bindQName, sequenceQName, newNameName, liftName,
+    returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName,
     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
     mkNameSName,
     liftStringName,
@@ -206,7 +206,7 @@ overlapTyConName       = thTc (fsLit "Overlap")        overlapTyConKey
 returnQName, bindQName, sequenceQName, newNameName, liftName,
     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
     mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeQName,
-    unsafeTExpCoerceName :: Name
+    unsafeTExpCoerceName, liftTypedName :: Name
 returnQName    = thFun (fsLit "returnQ")   returnQIdKey
 bindQName      = thFun (fsLit "bindQ")     bindQIdKey
 sequenceQName  = thFun (fsLit "sequenceQ") sequenceQIdKey
@@ -222,6 +222,7 @@ mkNameSName    = thFun (fsLit "mkNameS")    mkNameSIdKey
 unTypeName     = thFun (fsLit "unType")     unTypeIdKey
 unTypeQName    = thFun (fsLit "unTypeQ")    unTypeQIdKey
 unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey
+liftTypedName = thFun (fsLit "liftTyped") liftTypedIdKey
 
 
 -------------------- TH.Lib -----------------------
@@ -726,7 +727,7 @@ incoherentDataConKey   = mkPreludeDataConUnique 212
 returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
     mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
     mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeQIdKey,
-    unsafeTExpCoerceIdKey :: Unique
+    unsafeTExpCoerceIdKey, liftTypedIdKey :: Unique
 returnQIdKey        = mkPreludeMiscIdUnique 200
 bindQIdKey          = mkPreludeMiscIdUnique 201
 sequenceQIdKey      = mkPreludeMiscIdUnique 202
@@ -741,6 +742,7 @@ mkNameSIdKey         = mkPreludeMiscIdUnique 210
 unTypeIdKey          = mkPreludeMiscIdUnique 211
 unTypeQIdKey         = mkPreludeMiscIdUnique 212
 unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 213
+liftTypedIdKey        = mkPreludeMiscIdUnique 214
 
 
 -- data Lit = ...
@@ -1078,8 +1080,9 @@ viaStrategyIdKey      = mkPreludeDataConUnique 497
 ************************************************************************
 -}
 
-lift_RDR, mkNameG_dRDR, mkNameG_vRDR :: RdrName
+lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR :: RdrName
 lift_RDR     = nameRdrName liftName
+liftTyped_RDR = nameRdrName liftTypedName
 mkNameG_dRDR = nameRdrName mkNameG_dName
 mkNameG_vRDR = nameRdrName mkNameG_vName
 
diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs
index 89e5569c1e..daadf57313 100644
--- a/compiler/typecheck/Inst.hs
+++ b/compiler/typecheck/Inst.hs
@@ -78,24 +78,30 @@ import Control.Monad( unless )
 ************************************************************************
 -}
 
-newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr GhcTcId)
--- Used when Name is the wired-in name for a wired-in class method,
+newMethodFromName
+  :: CtOrigin              -- ^ why do we need this?
+  -> Name                  -- ^ name of the method
+  -> [TcRhoType]           -- ^ types with which to instantiate the class
+  -> TcM (HsExpr GhcTcId)
+-- ^ Used when 'Name' is the wired-in name for a wired-in class method,
 -- so the caller knows its type for sure, which should be of form
---    forall a. C a => <blah>
--- newMethodFromName is supposed to instantiate just the outer
+--
+-- > forall a. C a => <blah>
+--
+-- 'newMethodFromName' is supposed to instantiate just the outer
 -- type variable and constraint
 
-newMethodFromName origin name inst_ty
+newMethodFromName origin name ty_args
   = do { id <- tcLookupId name
               -- Use tcLookupId not tcLookupGlobalId; the method is almost
               -- always a class op, but with -XRebindableSyntax GHC is
               -- meant to find whatever thing is in scope, and that may
               -- be an ordinary function.
 
-       ; let ty = piResultTy (idType id) inst_ty
+       ; let ty = piResultTys (idType id) ty_args
              (theta, _caller_knows_this) = tcSplitPhiTy ty
        ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )
-                 instCall origin [inst_ty] theta
+                 instCall origin ty_args theta
 
        ; return (mkHsWrap wrap (HsVar noExt (noLoc id))) }
 
@@ -607,7 +613,7 @@ tcSyntaxName :: CtOrigin
 
 tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm))
   | std_nm == user_nm
-  = do rhs <- newMethodFromName orig std_nm ty
+  = do rhs <- newMethodFromName orig std_nm [ty]
        return (std_nm, rhs)
 
 tcSyntaxName orig ty (std_nm, user_nm_expr) = do
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 826939d389..b7c1478da3 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -335,6 +335,8 @@ renameDeriv is_boot inst_infos bagBinds
     -- (See Note [Newtype-deriving instances] in TcGenDeriv)
     unsetXOptM LangExt.RebindableSyntax $
     -- See Note [Avoid RebindableSyntax when deriving]
+    setXOptM LangExt.TemplateHaskellQuotes $
+    -- DeriveLift makes uses of quotes
     do  {
         -- Bring the extra deriving stuff into scope
         -- before renaming the instances themselves
diff --git a/compiler/typecheck/TcDerivUtils.hs b/compiler/typecheck/TcDerivUtils.hs
index cb5f6da02d..e7c2451246 100644
--- a/compiler/typecheck/TcDerivUtils.hs
+++ b/compiler/typecheck/TcDerivUtils.hs
@@ -738,8 +738,10 @@ cond_enumOrProduct cls = cond_isEnumeration `orCond`
                          (cond_isProduct `andCond` cond_args cls)
 
 cond_args :: Class -> Condition
--- For some classes (eg Eq, Ord) we allow unlifted arg types
--- by generating specialised code.  For others (eg Data) we don't.
+-- ^ For some classes (eg 'Eq', 'Ord') we allow unlifted arg types
+-- by generating specialised code.  For others (eg 'Data') we don't.
+-- For even others (eg 'Lift'), unlifted types aren't even a special
+-- consideration!
 cond_args cls _ _ rep_tc
   = case bad_args of
       []     -> IsValid
@@ -748,7 +750,7 @@ cond_args cls _ _ rep_tc
   where
     bad_args = [ arg_ty | con <- tyConDataCons rep_tc
                         , arg_ty <- dataConOrigArgTys con
-                        , isUnliftedType arg_ty
+                        , isLiftedType_maybe arg_ty /= Just True
                         , not (ok_ty arg_ty) ]
 
     cls_key = classKey cls
@@ -756,7 +758,7 @@ cond_args cls _ _ rep_tc
      | cls_key == eqClassKey   = check_in arg_ty ordOpTbl
      | cls_key == ordClassKey  = check_in arg_ty ordOpTbl
      | cls_key == showClassKey = check_in arg_ty boxConTbl
-     | cls_key == liftClassKey = check_in arg_ty litConTbl
+     | cls_key == liftClassKey = True     -- Lift is levity-polymorphic
      | otherwise               = False    -- Read, Ix etc
 
     check_in :: Type -> [(Type,a)] -> Bool
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 4d813b0086..adaea90767 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -639,7 +639,8 @@ tcExpr (HsStatic fvs expr) res_ty
         ; emitStaticConstraints lie
 
         -- Wrap the static form with the 'fromStaticPtr' call.
-        ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName p_ty
+        ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName
+                                             [p_ty]
         ; let wrap = mkWpTyApps [expr_ty]
         ; loc <- getSrcSpanM
         ; return $ mkHsWrapCo co $ HsApp noExt
@@ -1040,7 +1041,7 @@ tcArithSeq witness seq@(From expr) res_ty
   = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty
        ; expr' <- tcPolyExpr expr elt_ty
        ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
-                              enumFromName elt_ty
+                              enumFromName [elt_ty]
        ; return $ mkHsWrap wrap $
          ArithSeq enum_from wit' (From expr') }
 
@@ -1049,7 +1050,7 @@ tcArithSeq witness seq@(FromThen expr1 expr2) res_ty
        ; expr1' <- tcPolyExpr expr1 elt_ty
        ; expr2' <- tcPolyExpr expr2 elt_ty
        ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
-                              enumFromThenName elt_ty
+                              enumFromThenName [elt_ty]
        ; return $ mkHsWrap wrap $
          ArithSeq enum_from_then wit' (FromThen expr1' expr2') }
 
@@ -1058,7 +1059,7 @@ tcArithSeq witness seq@(FromTo expr1 expr2) res_ty
        ; expr1' <- tcPolyExpr expr1 elt_ty
        ; expr2' <- tcPolyExpr expr2 elt_ty
        ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
-                              enumFromToName elt_ty
+                              enumFromToName [elt_ty]
        ; return $ mkHsWrap wrap $
          ArithSeq enum_from_to wit' (FromTo expr1' expr2') }
 
@@ -1068,7 +1069,7 @@ tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty
         ; expr2' <- tcPolyExpr expr2 elt_ty
         ; expr3' <- tcPolyExpr expr3 elt_ty
         ; eft <- newMethodFromName (ArithSeqOrigin seq)
-                              enumFromThenToName elt_ty
+                              enumFromThenToName [elt_ty]
         ; return $ mkHsWrap wrap $
           ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') }
 
@@ -2041,7 +2042,8 @@ checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var))
                      setConstraintVar lie_var   $
                           -- Put the 'lift' constraint into the right LIE
                      newMethodFromName (OccurrenceOf id_name)
-                                       THNames.liftName id_ty
+                                       THNames.liftName
+                                       [getRuntimeRep id_ty, id_ty]
 
                    -- Update the pending splices
         ; ps <- readMutVar ps_var
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index bb4b643e86..b02494b634 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -54,8 +54,6 @@ import FamInst
 import FamInstEnv
 import PrelNames
 import THNames
-import Module ( moduleName, moduleNameString
-              , moduleUnitId, unitIdString )
 import MkId ( coerceId )
 import PrimOp
 import SrcLoc
@@ -1559,68 +1557,36 @@ Example:
     ==>
 
     instance (Lift a) => Lift (Foo a) where
-        lift (Foo a)
-          = appE
-              (conE
-                (mkNameG_d "package-name" "ModuleName" "Foo"))
-              (lift a)
-        lift (u :^: v)
-          = infixApp
-              (lift u)
-              (conE
-                (mkNameG_d "package-name" "ModuleName" ":^:"))
-              (lift v)
-
-Note that (mkNameG_d "package-name" "ModuleName" "Foo") is equivalent to what
-'Foo would be when using the -XTemplateHaskell extension. To make sure that
--XDeriveLift can be used on stage-1 compilers, however, we explicitly invoke
-makeG_d.
+        lift (Foo a) = [| Foo a |]
+        lift ((:^:) u v) = [| (:^:) u v |]
+
+        liftTyped (Foo a) = [|| Foo a ||]
+        liftTyped ((:^:) u v) = [|| (:^:) u v ||]
 -}
 
+
 gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
-gen_Lift_binds loc tycon = (unitBag lift_bind, emptyBag)
+gen_Lift_binds loc tycon = (listToBag [lift_bind, liftTyped_bind], emptyBag)
   where
-    lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)
-                            (map pats_etc data_cons)
+    lift_bind      = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)
+                                 (map (pats_etc mk_exp) data_cons)
+    liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp pure_Expr)
+                                 (map (pats_etc mk_texp) data_cons)
+
+    mk_exp = ExpBr NoExt
+    mk_texp = TExpBr NoExt
     data_cons = tyConDataCons tycon
 
-    pats_etc data_con
+    pats_etc mk_bracket data_con
       = ([con_pat], lift_Expr)
        where
             con_pat      = nlConVarPat data_con_RDR as_needed
             data_con_RDR = getRdrName data_con
             con_arity    = dataConSourceArity data_con
             as_needed    = take con_arity as_RDRs
-            lifted_as    = zipWithEqual "mk_lift_app" mk_lift_app
-                             tys_needed as_needed
-            tycon_name   = tyConName tycon
-            is_infix     = dataConIsInfix data_con
-            tys_needed   = dataConOrigArgTys data_con
-
-            mk_lift_app ty a
-              | not (isUnliftedType ty) = nlHsApp (nlHsVar lift_RDR)
-                                                  (nlHsVar a)
-              | otherwise = nlHsApp (nlHsVar litE_RDR)
-                              (primLitOp (mkBoxExp (nlHsVar a)))
-              where (primLitOp, mkBoxExp) = primLitOps "Lift" ty
-
-            pkg_name = unitIdString . moduleUnitId
-                     . nameModule $ tycon_name
-            mod_name = moduleNameString . moduleName . nameModule $ tycon_name
-            con_name = occNameString . nameOccName . dataConName $ data_con
-
-            conE_Expr = nlHsApp (nlHsVar conE_RDR)
-                                (nlHsApps mkNameG_dRDR
-                                  (map (nlHsLit . mkHsString)
-                                    [pkg_name, mod_name, con_name]))
-
-            lift_Expr
-              | is_infix  = nlHsApps infixApp_RDR [a1, conE_Expr, a2]
-              | otherwise = foldl' mk_appE_app conE_Expr lifted_as
-            (a1:a2:_) = lifted_as
-
-mk_appE_app :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
-mk_appE_app a b = nlHsApps appE_RDR [a, b]
+            lift_Expr    = noLoc (HsBracket NoExt (mk_bracket br_body))
+            br_body      = nlHsApps (Exact (dataConName data_con))
+                                    (map nlHsVar as_needed)
 
 {-
 ************************************************************************
@@ -2134,17 +2100,6 @@ primOrdOps :: String    -- The class involved
 -- See Note [Deriving and unboxed types] in TcDerivInfer
 primOrdOps str ty = assoc_ty_id str ordOpTbl ty
 
-primLitOps :: String -- The class involved
-           -> Type   -- The type
-           -> ( LHsExpr GhcPs -> LHsExpr GhcPs -- Constructs a Q Exp value
-              , LHsExpr GhcPs -> LHsExpr GhcPs -- Constructs a boxed value
-              )
-primLitOps str ty = (assoc_ty_id str litConTbl ty, \v -> boxed v)
-  where
-    boxed v
-      | ty `eqType` addrPrimTy = nlHsVar unpackCString_RDR `nlHsApp` v
-      | otherwise = assoc_ty_id str boxConTbl ty v
-
 ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
 ordOpTbl
  =  [(charPrimTy  , (ltChar_RDR  , leChar_RDR
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index c495a72d49..845e2029ed 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -177,13 +177,14 @@ tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty
        ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $
                                 tcInferRhoNC expr
                                 -- NC for no context; tcBracket does that
+       ; let rep = getRuntimeRep expr_ty
 
        ; meta_ty <- tcTExpTy expr_ty
        ; ps' <- readMutVar ps_ref
        ; texpco <- tcLookupId unsafeTExpCoerceName
        ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr")
                        rn_expr
-                       (unLoc (mkHsApp (nlHsTyApp texpco [expr_ty])
+                       (unLoc (mkHsApp (nlHsTyApp texpco [rep, expr_ty])
                                       (noLoc (HsTcBracketOut noExt brack ps'))))
                        meta_ty res_ty }
 tcTypedBracket _ other_brack _
@@ -230,7 +231,8 @@ tcTExpTy exp_ty
   = do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty)
        ; q    <- tcLookupTyCon qTyConName
        ; texp <- tcLookupTyCon tExpTyConName
-       ; return (mkTyConApp q [mkTyConApp texp [exp_ty]]) }
+       ; let rep = getRuntimeRep exp_ty
+       ; return (mkTyConApp q [mkTyConApp texp [rep, exp_ty]]) }
   where
     err_msg ty
       = vcat [ text "Illegal polytype:" <+> ppr ty
@@ -469,12 +471,13 @@ tcNestedSplice :: ThStage -> PendingStuff -> Name
     -- A splice inside brackets
 tcNestedSplice pop_stage (TcPending ps_var lie_var) splice_name expr res_ty
   = do { res_ty <- expTypeToType res_ty
+       ; let rep = getRuntimeRep res_ty
        ; meta_exp_ty <- tcTExpTy res_ty
        ; expr' <- setStage pop_stage $
                   setConstraintVar lie_var $
                   tcMonoExpr expr (mkCheckExpType meta_exp_ty)
        ; untypeq <- tcLookupId unTypeQName
-       ; let expr'' = mkHsApp (nlHsTyApp untypeq [res_ty]) expr'
+       ; let expr'' = mkHsApp (nlHsTyApp untypeq [rep, res_ty]) expr'
        ; ps <- readMutVar ps_var
        ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps)
 
diff --git a/docs/users_guide/8.10.1-notes.rst b/docs/users_guide/8.10.1-notes.rst
index 21a7f2b275..1c47a002d7 100644
--- a/docs/users_guide/8.10.1-notes.rst
+++ b/docs/users_guide/8.10.1-notes.rst
@@ -73,6 +73,12 @@ Runtime system
 Template Haskell
 ~~~~~~~~~~~~~~~~
 
+- The ``Lift`` typeclass is now levity-polymorphic and has a ``liftTyped``
+  method. Previously disallowed instances for unboxed tuples, unboxed sums, an
+  primitive unboxed types have also been added. Finally, the code generated by
+  :ghc-flags:`-XDeriveLift` has been simplified to take advantage of expression
+  quotations.
+
 ``ghc-prim`` library
 ~~~~~~~~~~~~~~~~~~~~
 
diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst
index 1c1d4cbb85..781a10691e 100644
--- a/docs/users_guide/glasgow_exts.rst
+++ b/docs/users_guide/glasgow_exts.rst
@@ -4531,7 +4531,8 @@ Deriving ``Lift`` instances
 The class ``Lift``, unlike other derivable classes, lives in
 ``template-haskell`` instead of ``base``. Having a data type be an instance of
 ``Lift`` permits its values to be promoted to Template Haskell expressions (of
-type ``ExpQ``), which can then be spliced into Haskell source code.
+type ``ExpQ`` and ``TExpQ a``), which can then be spliced into Haskell source
+code.
 
 Here is an example of how one can derive ``Lift``:
 
@@ -4546,17 +4547,11 @@ Here is an example of how one can derive ``Lift``:
 
     {-
     instance (Lift a) => Lift (Foo a) where
-        lift (Foo a)
-        = appE
-            (conE
-                (mkNameG_d "package-name" "Bar" "Foo"))
-            (lift a)
-        lift (u :^: v)
-        = infixApp
-            (lift u)
-            (conE
-                (mkNameG_d "package-name" "Bar" ":^:"))
-            (lift v)
+        lift (Foo a) = [| Foo a |]
+        lift ((:^:) u v) = [| (:^:) u v |]
+
+        liftTyped (Foo a) = [|| Foo a ||]
+        liftTyped ((:^:) u v) = [|| (:^:) u v ||]
     -}
 
     -----
@@ -4572,8 +4567,9 @@ Here is an example of how one can derive ``Lift``:
     fooExp :: Lift a => Foo a -> Q Exp
     fooExp f = [| f |]
 
-:extension:`DeriveLift` also works for certain unboxed types (``Addr#``, ``Char#``,
-``Double#``, ``Float#``, ``Int#``, and ``Word#``):
+Note that the ``Lift`` typeclass takes advantage of :ref:`runtime-rep` in order
+to support instances involving unboxed types. This means :extension:`DeriveLift`
+also works for these types:
 
 ::
 
@@ -4587,12 +4583,8 @@ Here is an example of how one can derive ``Lift``:
 
     {-
     instance Lift IntHash where
-        lift (IntHash i)
-        = appE
-            (conE
-                (mkNameG_d "package-name" "Unboxed" "IntHash"))
-            (litE
-                (intPrimL (toInteger (I# i))))
+        lift (IntHash i) = [| IntHash i |]
+        liftTyped (IntHash i) = [|| IntHash i ||]
     -}
 
 
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 31422a1b66..14b9de263c 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -1,6 +1,8 @@
 {-# LANGUAGE CPP, DeriveDataTypeable,
              DeriveGeneric, FlexibleInstances, DefaultSignatures,
              RankNTypes, RoleAnnotations, ScopedTypeVariables,
+             MagicHash, KindSignatures, PolyKinds, TypeApplications, DataKinds,
+             GADTs, UnboxedTuples, UnboxedSums, TypeInType,
              Trustworthy #-}
 
 {-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-}
@@ -32,13 +34,17 @@ import System.IO.Unsafe ( unsafePerformIO )
 import Control.Monad (liftM)
 import Control.Monad.IO.Class (MonadIO (..))
 import System.IO        ( hPutStrLn, stderr )
-import Data.Char        ( isAlpha, isAlphaNum, isUpper )
+import Data.Char        ( isAlpha, isAlphaNum, isUpper, ord )
 import Data.Int
 import Data.List.NonEmpty ( NonEmpty(..) )
 import Data.Void        ( Void, absurd )
 import Data.Word
 import Data.Ratio
+import GHC.CString      ( unpackCString# )
 import GHC.Generics     ( Generic )
+import GHC.Types        ( Int(..), Word(..), Char(..), Double(..), Float(..),
+                          TYPE, RuntimeRep(..) )
+import GHC.Prim         ( Int#, Word#, Char#, Double#, Float#, Addr# )
 import GHC.Lexeme       ( startsVarSym, startsVarId )
 import GHC.ForeignSrcLang.Type
 import Language.Haskell.TH.LanguageExtensions
@@ -201,7 +207,7 @@ instance Applicative Q where
 -----------------------------------------------------
 
 type role TExp nominal   -- See Note [Role of TExp]
-newtype TExp a = TExp
+newtype TExp (a :: TYPE (r :: RuntimeRep)) = TExp
   { unType :: Exp -- ^ Underlying untyped Template Haskell expression
   }
 -- ^ Represents an expression which has type @a@. Built on top of 'Exp', typed
@@ -240,7 +246,9 @@ newtype TExp a = TExp
 
 -- | Discard the type annotation and produce a plain Template Haskell
 -- expression
-unTypeQ :: Q (TExp a) -> Q Exp
+--
+-- Levity-polymorphic since /template-haskell-2.16.0.0/.
+unTypeQ :: forall (r :: RuntimeRep) (a :: TYPE r). Q (TExp a) -> Q Exp
 unTypeQ m = do { TExp e <- m
                ; return e }
 
@@ -248,7 +256,9 @@ unTypeQ m = do { TExp e <- m
 --
 -- 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)
+--
+-- Levity-polymorphic since /template-haskell-2.16.0.0/.
+unsafeTExpCoerce :: forall (r :: RuntimeRep) (a :: TYPE r). Q Exp -> Q (TExp a)
 unsafeTExpCoerce m = do { e <- m
                         ; return (TExp e) }
 
@@ -651,17 +661,18 @@ sequenceQ = sequence
 
 -- | A 'Lift' instance can have any of its values turned into a Template
 -- Haskell expression. This is needed when a value used within a Template
--- Haskell quotation is bound outside the Oxford brackets (@[| ... |]@) but not
--- at the top level. As an example:
+-- Haskell quotation is bound outside the Oxford brackets (@[| ... |]@ or
+-- @[|| ... ||]@) but not at the top level. As an example:
 --
--- > add1 :: Int -> Q Exp
--- > add1 x = [| x + 1 |]
+-- > add1 :: Int -> Q (TExp Int)
+-- > add1 x = [|| x + 1 ||]
 --
 -- Template Haskell has no way of knowing what value @x@ will take on at
 -- splice-time, so it requires the type of @x@ to be an instance of 'Lift'.
 --
--- A 'Lift' instance must satisfy @$(lift x) ≡ x@ for all @x@, where @$(...)@
--- is a Template Haskell splice.
+-- A 'Lift' instance must satisfy @$(lift x) ≡ x@ and @$$(liftTyped x) ≡ x@
+-- for all @x@, where @$(...)@ and @$$(...)@ are Template Haskell splices.
+-- It is additionally expected that @'lift' x ≡ 'unTypeQ' ('liftTyped' x)@.
 --
 -- 'Lift' instances can be derived automatically by use of the @-XDeriveLift@
 -- GHC language extension:
@@ -673,10 +684,13 @@ sequenceQ = sequence
 -- >
 -- > data Bar a = Bar1 a (Bar a) | Bar2 String
 -- >   deriving Lift
-class Lift t where
+--
+-- Levity-polymorphic since /template-haskell-2.16.0.0/.
+class Lift (t :: TYPE r) where
   -- | Turn a value into a Template Haskell expression, suitable for use in
   -- a splice.
   lift :: t -> Q Exp
+  default lift :: (r ~ 'LiftedRep) => t -> Q Exp
   lift = unTypeQ . liftTyped
 
   -- | Turn a value into a Template Haskell typed expression, suitable for use
@@ -684,73 +698,127 @@ class Lift t where
   --
   -- @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
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (IntegerL x))
 
 instance Lift Int where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
+-- | @since 2.16.0.0
+instance Lift Int# where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift x = return (LitE (IntPrimL (fromIntegral (I# x))))
+
 instance Lift Int8 where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Lift Int16 where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Lift Int32 where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Lift Int64 where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
+-- | @since 2.16.0.0
+instance Lift Word# where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift x = return (LitE (WordPrimL (fromIntegral (W# x))))
+
 instance Lift Word where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Lift Word8 where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Lift Word16 where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Lift Word32 where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Lift Word64 where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Lift Natural where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Integral a => Lift (Ratio a) where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (RationalL (toRational x)))
 
 instance Lift Float where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (RationalL (toRational x)))
 
+-- | @since 2.16.0.0
+instance Lift Float# where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift x = return (LitE (FloatPrimL (toRational (F# x))))
+
 instance Lift Double where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (RationalL (toRational x)))
 
+-- | @since 2.16.0.0
+instance Lift Double# where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift x = return (LitE (DoublePrimL (toRational (D# x))))
+
 instance Lift Char where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift x = return (LitE (CharL x))
 
+-- | @since 2.16.0.0
+instance Lift Char# where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift x = return (LitE (CharPrimL (C# x)))
+
 instance Lift Bool where
+  liftTyped x = unsafeTExpCoerce (lift x)
+
   lift True  = return (ConE trueName)
   lift False = return (ConE falseName)
 
+-- | Produces an 'Addr#' literal from the NUL-terminated C-string starting at
+-- the given memory address.
+--
+-- @since 2.16.0.0
+instance Lift Addr# where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift x
+    = return (LitE (StringPrimL (map (fromIntegral . ord) (unpackCString# x))))
+
 instance Lift a => Lift (Maybe a) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+
   lift Nothing  = return (ConE nothingName)
   lift (Just x) = liftM (ConE justName `AppE`) (lift x)
 
 instance (Lift a, Lift b) => Lift (Either a b) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+
   lift (Left x)  = liftM (ConE leftName  `AppE`) (lift x)
   lift (Right y) = liftM (ConE rightName `AppE`) (lift y)
 
 instance Lift a => Lift [a] where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift xs = do { xs' <- mapM lift xs; return (ListE xs') }
 
 liftString :: String -> Q Exp
@@ -759,6 +827,8 @@ liftString s = return (LitE (StringL s))
 
 -- | @since 2.15.0.0
 instance Lift a => Lift (NonEmpty a) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+
   lift (x :| xs) = do
     x' <- lift x
     xs' <- lift xs
@@ -766,38 +836,166 @@ instance Lift a => Lift (NonEmpty a) where
 
 -- | @since 2.15.0.0
 instance Lift Void where
+  liftTyped = pure . absurd
   lift = pure . absurd
 
 instance Lift () where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift () = return (ConE (tupleDataName 0))
 
 instance (Lift a, Lift b) => Lift (a, b) where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift (a, b)
     = liftM TupE $ sequence [lift a, lift b]
 
 instance (Lift a, Lift b, Lift c) => Lift (a, b, c) where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift (a, b, c)
     = liftM TupE $ sequence [lift a, lift b, lift c]
 
 instance (Lift a, Lift b, Lift c, Lift d) => Lift (a, b, c, d) where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift (a, b, c, d)
     = liftM TupE $ sequence [lift a, lift b, lift c, lift d]
 
 instance (Lift a, Lift b, Lift c, Lift d, Lift e)
       => Lift (a, b, c, d, e) where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift (a, b, c, d, e)
     = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e]
 
 instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
       => Lift (a, b, c, d, e, f) where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift (a, b, c, d, e, f)
     = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f]
 
 instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
       => Lift (a, b, c, d, e, f, g) where
+  liftTyped x = unsafeTExpCoerce (lift x)
   lift (a, b, c, d, e, f, g)
     = liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f, lift g]
 
+-- | @since 2.16.0.0
+instance Lift (# #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift (# #) = return (ConE (unboxedTupleTypeName 0))
+
+-- | @since 2.16.0.0
+instance (Lift a) => Lift (# a #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift (# a #)
+    = liftM UnboxedTupE $ sequence [lift a]
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b) => Lift (# a, b #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift (# a, b #)
+    = liftM UnboxedTupE $ sequence [lift a, lift b]
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c)
+      => Lift (# a, b, c #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift (# a, b, c #)
+    = liftM UnboxedTupE $ sequence [lift a, lift b, lift c]
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c, Lift d)
+      => Lift (# a, b, c, d #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift (# a, b, c, d #)
+    = liftM UnboxedTupE $ sequence [lift a, lift b, lift c, lift d]
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c, Lift d, Lift e)
+      => Lift (# a, b, c, d, e #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift (# a, b, c, d, e #)
+    = liftM UnboxedTupE $ sequence [lift a, lift b, lift c, lift d, lift e]
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
+      => Lift (# a, b, c, d, e, f #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift (# a, b, c, d, e, f #)
+    = liftM UnboxedTupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f]
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
+      => Lift (# a, b, c, d, e, f, g #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift (# a, b, c, d, e, f, g #)
+    = liftM UnboxedTupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f, lift g]
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b) => Lift (# a | b #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift x
+    = case x of
+        (# y | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 2
+        (# | y #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 2
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c)
+      => Lift (# a | b | c #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift x
+    = case x of
+        (# y | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 3
+        (# | y | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 3
+        (# | | y #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 3
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c, Lift d)
+      => Lift (# a | b | c | d #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift x
+    = case x of
+        (# y | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 4
+        (# | y | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 4
+        (# | | y | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 4
+        (# | | | y #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 4
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c, Lift d, Lift e)
+      => Lift (# a | b | c | d | e #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift x
+    = case x of
+        (# y | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 5
+        (# | y | | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 5
+        (# | | y | | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 5
+        (# | | | y | #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 5
+        (# | | | | y #) -> UnboxedSumE <$> lift y <*> pure 5 <*> pure 5
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
+      => Lift (# a | b | c | d | e | f #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift x
+    = case x of
+        (# y | | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 6
+        (# | y | | | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 6
+        (# | | y | | | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 6
+        (# | | | y | | #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 6
+        (# | | | | y | #) -> UnboxedSumE <$> lift y <*> pure 5 <*> pure 6
+        (# | | | | | y #) -> UnboxedSumE <$> lift y <*> pure 6 <*> pure 6
+
+-- | @since 2.16.0.0
+instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
+      => Lift (# a | b | c | d | e | f | g #) where
+  liftTyped x = unsafeTExpCoerce (lift x)
+  lift x
+    = case x of
+        (# y | | | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 7
+        (# | y | | | | | #) -> UnboxedSumE <$> lift y <*> pure 2 <*> pure 7
+        (# | | y | | | | #) -> UnboxedSumE <$> lift y <*> pure 3 <*> pure 7
+        (# | | | y | | | #) -> UnboxedSumE <$> lift y <*> pure 4 <*> pure 7
+        (# | | | | y | | #) -> UnboxedSumE <$> lift y <*> pure 5 <*> pure 7
+        (# | | | | | y | #) -> UnboxedSumE <$> lift y <*> pure 6 <*> pure 7
+        (# | | | | | | y #) -> UnboxedSumE <$> lift y <*> pure 7 <*> pure 7
+
 -- TH has a special form for literal strings,
 -- which we should take advantage of.
 -- NB: the lhs of the rule has no args, so that
@@ -1619,8 +1817,8 @@ data Lit = CharL Char
          | WordPrimL Integer
          | FloatPrimL Rational
          | DoublePrimL Rational
-         | StringPrimL [Word8]  -- ^ A primitive C-style string, type Addr#
-         | BytesPrimL Bytes     -- ^ Some raw bytes, type Addr#:
+         | StringPrimL [Word8]  -- ^ A primitive C-style string, type 'Addr#'
+         | BytesPrimL Bytes     -- ^ Some raw bytes, type 'Addr#':
          | CharPrimL Char
     deriving( Show, Eq, Ord, Data, Generic )
 
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index 9928df9ba9..0958f0c163 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -3,7 +3,7 @@
 ## 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.
+    implementations of `lift` in terms of `liftTyped`.
 
   * Add a `ForallVisT` constructor to `Type` to represent visible, dependent
     quantification.
@@ -11,6 +11,9 @@
   * Introduce support for `Bytes` literals (raw bytes embedded into the output
     binary)
 
+  * Make the `Lift` typeclass levity-polymorphic and add instances for unboxed
+    tuples, unboxed sums, `Int#`, `Word#`, `Addr#`, `Float#`, and `Double#`.
+
 ## 2.15.0.0 *TBA*
 
   * In `Language.Haskell.TH.Syntax`, `DataInstD`, `NewTypeInstD`, `TySynEqn`,
diff --git a/libraries/template-haskell/template-haskell.cabal.in b/libraries/template-haskell/template-haskell.cabal.in
index 3f79b3b895..7acbf026c1 100644
--- a/libraries/template-haskell/template-haskell.cabal.in
+++ b/libraries/template-haskell/template-haskell.cabal.in
@@ -57,6 +57,7 @@ Library
     build-depends:
         base        >= 4.11 && < 4.14,
         ghc-boot-th == @ProjectVersionMunged@,
+        ghc-prim,
         pretty      == 1.1.*
 
     ghc-options: -Wall
diff --git a/testsuite/tests/deriving/should_compile/T14682.stderr b/testsuite/tests/deriving/should_compile/T14682.stderr
index 75e9030bc7..7656c9c3b8 100644
--- a/testsuite/tests/deriving/should_compile/T14682.stderr
+++ b/testsuite/tests/deriving/should_compile/T14682.stderr
@@ -13,13 +13,12 @@ Derived class instances:
   
   instance Language.Haskell.TH.Syntax.Lift T14682.Foo where
     Language.Haskell.TH.Syntax.lift (T14682.Foo a1 a2)
-      = Language.Haskell.TH.Lib.Internal.appE
-          (Language.Haskell.TH.Lib.Internal.appE
-             (Language.Haskell.TH.Lib.Internal.conE
-                (Language.Haskell.TH.Syntax.mkNameG_d "main" "T14682" "Foo"))
-             (Language.Haskell.TH.Syntax.lift a1))
-          (Language.Haskell.TH.Syntax.lift a2)
-  
+      = [| T14682.Foo a1 a2 |]
+        pending(rn) [<a2, Language.Haskell.TH.Syntax.lift a2>,
+                     <a1, Language.Haskell.TH.Syntax.lift a1>]
+    Language.Haskell.TH.Syntax.liftTyped (T14682.Foo a1 a2)
+      = [|| T14682.Foo a1 a2 ||]
+
   instance Data.Data.Data T14682.Foo where
     Data.Data.gfoldl k z (T14682.Foo a1 a2)
       = ((z T14682.Foo `k` a1) `k` a2)
@@ -98,13 +97,6 @@ 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)
 
diff --git a/testsuite/tests/deriving/should_compile/drv-empty-data.stderr b/testsuite/tests/deriving/should_compile/drv-empty-data.stderr
index 5baf6a6c6e..d6e4eee4b0 100644
--- a/testsuite/tests/deriving/should_compile/drv-empty-data.stderr
+++ b/testsuite/tests/deriving/should_compile/drv-empty-data.stderr
@@ -46,6 +46,7 @@ Derived class instances:
   instance Language.Haskell.TH.Syntax.Lift
              (DrvEmptyData.Void a) where
     Language.Haskell.TH.Syntax.lift z = GHC.Base.pure (case z of)
+    Language.Haskell.TH.Syntax.liftTyped z = GHC.Base.pure (case z of)
   
   DrvEmptyData.$tVoid :: Data.Data.DataType
   DrvEmptyData.$tVoid = Data.Data.mkDataType "Void" []
diff --git a/testsuite/tests/quotes/TH_localname.stderr b/testsuite/tests/quotes/TH_localname.stderr
index df38597f2c..d872a622b3 100644
--- a/testsuite/tests/quotes/TH_localname.stderr
+++ b/testsuite/tests/quotes/TH_localname.stderr
@@ -9,17 +9,7 @@ TH_localname.hs:3:11: error:
           (bound at TH_localname.hs:3:1)
       Probable fix: use a type annotation to specify what ‘t0’ should be.
       These potential instances exist:
-        instance (Language.Haskell.TH.Syntax.Lift a,
-                  Language.Haskell.TH.Syntax.Lift b) =>
-                 Language.Haskell.TH.Syntax.Lift (Either a b)
-          -- Defined in ‘Language.Haskell.TH.Syntax’
-        instance Language.Haskell.TH.Syntax.Lift Integer
-          -- Defined in ‘Language.Haskell.TH.Syntax’
-        instance Language.Haskell.TH.Syntax.Lift a =>
-                 Language.Haskell.TH.Syntax.Lift (Maybe a)
-          -- Defined in ‘Language.Haskell.TH.Syntax’
-        ...plus 14 others
-        ...plus 12 instances involving out-of-scope types
+        29 instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
     • In the expression: Language.Haskell.TH.Syntax.lift y
       In the expression: