Use a newtype `Code` for the return type of typed quotations (Proposal #195)wip/proposal-195

There are three problems with the current API:

1. It is hard to properly write instances for ``Quote m => m (TExp a)`` as the type is the composition
   of two type constructors. Doing so in your program involves making your own newtype and
   doing a lot of wrapping/unwrapping.

   For example, if I want to create a language which I can either run immediately or
   generate code from I could write the following with the new API. ::

      class Lang r where
        _int :: Int -> r Int
        _if  :: r Bool -> r a -> r a -> r a

      instance Lang Identity where
        _int = Identity
        _if (Identity b) (Identity t) (Identity f) = Identity (if b then t else f)

      instance Quote m => Lang (Code m) where
        _int = liftTyped
        _if cb ct cf = [|| if $$cb then $$ct else $$cf ||]

2. When doing code generation it is common to want to store code fragments in
   a map. When doing typed code generation, these code fragments contain a
   type index so it is desirable to store them in one of the parameterised
   map data types such as ``DMap`` from ``dependent-map`` or ``MapF`` from
   ``parameterized-utils``.

   ::

      compiler :: Env -> AST a -> Code Q a

      data AST a where ...
      data Ident a = ...

      type Env = MapF Ident (Code Q)

      newtype Code m a = Code (m (TExp a))

   In this example, the ``MapF`` maps an ``Ident String`` directly to a ``Code Q String``.
   Using one of these map types currently requires creating your own newtype and constantly
   wrapping every quotation and unwrapping it when using a splice. Achievable, but
   it creates even more syntactic noise than normal metaprogramming.

3. ``m (TExp a)`` is ugly to read and write, understanding ``Code m a`` is
   easier. This is a weak reason but one everyone
   can surely agree with.

Updates text submodule.

33 files changed, 230 insertions, 154 deletions

diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs
index 1e2e2f97a7..1903a7d108 100644
--- a/compiler/GHC/Builtin/Names/TH.hs
+++ b/compiler/GHC/Builtin/Names/TH.hs
@@ -32,9 +32,8 @@ templateHaskellNames = [
     mkNameSName,
     mkModNameName,
     liftStringName,
-    unTypeName,
-    unTypeQName,
-    unsafeTExpCoerceName,
+    unTypeName, unTypeCodeName,
+    unsafeCodeCoerceName,
 
     -- Lit
     charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
@@ -135,8 +134,6 @@ templateHaskellNames = [
     -- DerivStrategy
     stockStrategyName, anyclassStrategyName,
     newtypeStrategyName, viaStrategyName,
-    -- TExp
-    tExpDataConName,
     -- RuleBndr
     ruleVarName, typedRuleVarName,
     -- FunDep
@@ -159,7 +156,7 @@ templateHaskellNames = [
     typeTyConName, tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, clauseTyConName,
     patQTyConName, funDepTyConName, decsQTyConName,
     ruleBndrTyConName, tySynEqnTyConName,
-    roleTyConName, tExpTyConName, injAnnTyConName, kindTyConName,
+    roleTyConName, codeTyConName, injAnnTyConName, kindTyConName,
     overlapTyConName, derivClauseTyConName, derivStrategyTyConName,
     modNameTyConName,
 
@@ -193,7 +190,7 @@ quoteClassName = thCls (fsLit "Quote") quoteClassKey
 qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
     fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
     matchTyConName, clauseTyConName, funDepTyConName, predTyConName,
-    tExpTyConName, injAnnTyConName, overlapTyConName, decsTyConName,
+    codeTyConName, injAnnTyConName, overlapTyConName, decsTyConName,
     modNameTyConName :: Name
 qTyConName             = thTc (fsLit "Q")              qTyConKey
 nameTyConName          = thTc (fsLit "Name")           nameTyConKey
@@ -208,15 +205,15 @@ matchTyConName         = thTc (fsLit "Match")          matchTyConKey
 clauseTyConName        = thTc (fsLit "Clause")         clauseTyConKey
 funDepTyConName        = thTc (fsLit "FunDep")         funDepTyConKey
 predTyConName          = thTc (fsLit "Pred")           predTyConKey
-tExpTyConName          = thTc (fsLit "TExp")           tExpTyConKey
+codeTyConName          = thTc (fsLit "Code")           codeTyConKey
 injAnnTyConName        = thTc (fsLit "InjectivityAnn") injAnnTyConKey
 overlapTyConName       = thTc (fsLit "Overlap")        overlapTyConKey
 modNameTyConName       = thTc (fsLit "ModName")        modNameTyConKey
 
 returnQName, bindQName, sequenceQName, newNameName, liftName,
     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
-    mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeQName,
-    unsafeTExpCoerceName, liftTypedName, mkModNameName :: Name
+    mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeCodeName,
+    unsafeCodeCoerceName, liftTypedName, mkModNameName :: Name
 returnQName    = thFun (fsLit "returnQ")   returnQIdKey
 bindQName      = thFun (fsLit "bindQ")     bindQIdKey
 sequenceQName  = thFun (fsLit "sequenceQ") sequenceQIdKey
@@ -231,8 +228,8 @@ mkNameLName    = thFun (fsLit "mkNameL")    mkNameLIdKey
 mkNameSName    = thFun (fsLit "mkNameS")    mkNameSIdKey
 mkModNameName  = thFun (fsLit "mkModName")  mkModNameIdKey
 unTypeName     = thFun (fsLit "unType")     unTypeIdKey
-unTypeQName    = thFun (fsLit "unTypeQ")    unTypeQIdKey
-unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey
+unTypeCodeName    = thFun (fsLit "unTypeCode") unTypeCodeIdKey
+unsafeCodeCoerceName = thFun (fsLit "unsafeCodeCoerce") unsafeCodeCoerceIdKey
 liftTypedName = thFun (fsLit "liftTyped") liftTypedIdKey
 
 
@@ -525,10 +522,6 @@ unsafeName     = libFun (fsLit "unsafe") unsafeIdKey
 safeName       = libFun (fsLit "safe") safeIdKey
 interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey
 
--- newtype TExp a = ...
-tExpDataConName :: Name
-tExpDataConName = thCon (fsLit "TExp") tExpDataConKey
-
 -- data RuleBndr = ...
 ruleVarName, typedRuleVarName :: Name
 ruleVarName      = libFun (fsLit ("ruleVar"))      ruleVarIdKey
@@ -653,7 +646,7 @@ expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
     fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
     funDepTyConKey, predTyConKey,
     predQTyConKey, decsQTyConKey, ruleBndrTyConKey, tySynEqnTyConKey,
-    roleTyConKey, tExpTyConKey, injAnnTyConKey, kindTyConKey,
+    roleTyConKey, codeTyConKey, injAnnTyConKey, kindTyConKey,
     overlapTyConKey, derivClauseTyConKey, derivStrategyTyConKey, decsTyConKey,
     modNameTyConKey  :: Unique
 expTyConKey             = mkPreludeTyConUnique 200
@@ -667,7 +660,7 @@ conTyConKey             = mkPreludeTyConUnique 210
 typeQTyConKey           = mkPreludeTyConUnique 211
 typeTyConKey            = mkPreludeTyConUnique 212
 decTyConKey             = mkPreludeTyConUnique 213
-bangTypeTyConKey       = mkPreludeTyConUnique 214
+bangTypeTyConKey        = mkPreludeTyConUnique 214
 varBangTypeTyConKey     = mkPreludeTyConUnique 215
 fieldExpTyConKey        = mkPreludeTyConUnique 216
 fieldPatTyConKey        = mkPreludeTyConUnique 217
@@ -677,19 +670,19 @@ funDepTyConKey          = mkPreludeTyConUnique 222
 predTyConKey            = mkPreludeTyConUnique 223
 predQTyConKey           = mkPreludeTyConUnique 224
 tyVarBndrUnitTyConKey   = mkPreludeTyConUnique 225
-tyVarBndrSpecTyConKey   = mkPreludeTyConUnique 237
 decsQTyConKey           = mkPreludeTyConUnique 226
-ruleBndrTyConKey       = mkPreludeTyConUnique 227
+ruleBndrTyConKey        = mkPreludeTyConUnique 227
 tySynEqnTyConKey        = mkPreludeTyConUnique 228
 roleTyConKey            = mkPreludeTyConUnique 229
-tExpTyConKey            = mkPreludeTyConUnique 230
 injAnnTyConKey          = mkPreludeTyConUnique 231
-kindTyConKey           = mkPreludeTyConUnique 232
+kindTyConKey            = mkPreludeTyConUnique 232
 overlapTyConKey         = mkPreludeTyConUnique 233
-derivClauseTyConKey    = mkPreludeTyConUnique 234
-derivStrategyTyConKey  = mkPreludeTyConUnique 235
+derivClauseTyConKey     = mkPreludeTyConUnique 234
+derivStrategyTyConKey   = mkPreludeTyConUnique 235
 decsTyConKey            = mkPreludeTyConUnique 236
-modNameTyConKey         = mkPreludeTyConUnique 238
+tyVarBndrSpecTyConKey   = mkPreludeTyConUnique 237
+codeTyConKey            = mkPreludeTyConUnique 238
+modNameTyConKey         = mkPreludeTyConUnique 239
 
 {- *********************************************************************
 *                                                                      *
@@ -717,10 +710,6 @@ allPhasesDataConKey   = mkPreludeDataConUnique 205
 fromPhaseDataConKey   = mkPreludeDataConUnique 206
 beforePhaseDataConKey = mkPreludeDataConUnique 207
 
--- newtype TExp a = ...
-tExpDataConKey :: Unique
-tExpDataConKey = mkPreludeDataConUnique 208
-
 -- data Overlap = ..
 overlappableDataConKey,
   overlappingDataConKey,
@@ -742,8 +731,8 @@ incoherentDataConKey   = mkPreludeDataConUnique 212
 
 returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
     mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
-    mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeQIdKey,
-    unsafeTExpCoerceIdKey, liftTypedIdKey, mkModNameIdKey :: Unique
+    mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeCodeIdKey,
+    unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey :: Unique
 returnQIdKey        = mkPreludeMiscIdUnique 200
 bindQIdKey          = mkPreludeMiscIdUnique 201
 sequenceQIdKey      = mkPreludeMiscIdUnique 202
@@ -756,10 +745,10 @@ mkNameG_tcIdKey      = mkPreludeMiscIdUnique 208
 mkNameLIdKey         = mkPreludeMiscIdUnique 209
 mkNameSIdKey         = mkPreludeMiscIdUnique 210
 unTypeIdKey          = mkPreludeMiscIdUnique 211
-unTypeQIdKey         = mkPreludeMiscIdUnique 212
-unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 213
+unTypeCodeIdKey      = mkPreludeMiscIdUnique 212
 liftTypedIdKey        = mkPreludeMiscIdUnique 214
 mkModNameIdKey        = mkPreludeMiscIdUnique 215
+unsafeCodeCoerceIdKey = mkPreludeMiscIdUnique 216
 
 
 -- data Lit = ...
@@ -1105,9 +1094,10 @@ inferredSpecKey  = mkPreludeMiscIdUnique 499
 ************************************************************************
 -}
 
-lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR :: RdrName
+lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR, unsafeCodeCoerce_RDR :: RdrName
 lift_RDR     = nameRdrName liftName
 liftTyped_RDR = nameRdrName liftTypedName
+unsafeCodeCoerce_RDR = nameRdrName unsafeCodeCoerceName
 mkNameG_dRDR = nameRdrName mkNameG_dName
 mkNameG_vRDR = nameRdrName mkNameG_vName
 
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index f0655f5b4e..650bc16714 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -1621,7 +1621,7 @@ 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 mk_exp) data_cons)
-    liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp pure_Expr)
+    liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp unsafeCodeCoerce_Expr . nlHsApp pure_Expr)
                                  (map (pats_etc mk_texp) data_cons)
 
     mk_exp = ExpBr noExtField
@@ -2461,17 +2461,18 @@ bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) ..
 cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
 
 a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr,
-    true_Expr, pure_Expr :: LHsExpr GhcPs
-a_Expr          = nlHsVar a_RDR
-b_Expr          = nlHsVar b_RDR
-c_Expr          = nlHsVar c_RDR
-z_Expr          = nlHsVar z_RDR
-ltTag_Expr      = nlHsVar ltTag_RDR
-eqTag_Expr      = nlHsVar eqTag_RDR
-gtTag_Expr      = nlHsVar gtTag_RDR
-false_Expr      = nlHsVar false_RDR
-true_Expr       = nlHsVar true_RDR
-pure_Expr       = nlHsVar pure_RDR
+    true_Expr, pure_Expr, unsafeCodeCoerce_Expr :: LHsExpr GhcPs
+a_Expr                = nlHsVar a_RDR
+b_Expr                = nlHsVar b_RDR
+c_Expr                = nlHsVar c_RDR
+z_Expr                = nlHsVar z_RDR
+ltTag_Expr            = nlHsVar ltTag_RDR
+eqTag_Expr            = nlHsVar eqTag_RDR
+gtTag_Expr            = nlHsVar gtTag_RDR
+false_Expr            = nlHsVar false_RDR
+true_Expr             = nlHsVar true_RDR
+pure_Expr             = nlHsVar pure_RDR
+unsafeCodeCoerce_Expr = nlHsVar unsafeCodeCoerce_RDR
 
 a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat GhcPs
 a_Pat           = nlVarPat a_RDR
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 55a74e87b1..c18ce5f3cf 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -197,7 +197,7 @@ tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty
        ; let rep = getRuntimeRep expr_ty
        ; meta_ty <- tcTExpTy m_var expr_ty
        ; ps' <- readMutVar ps_ref
-       ; texpco <- tcLookupId unsafeTExpCoerceName
+       ; texpco <- tcLookupId unsafeCodeCoerceName
        ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr")
                        rn_expr
                        (unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper)
@@ -303,9 +303,9 @@ tcPendingSplice m_var (PendingRnSplice flavour splice_name expr)
 tcTExpTy :: TcType -> TcType -> TcM TcType
 tcTExpTy m_ty exp_ty
   = do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty)
-       ; texp <- tcLookupTyCon tExpTyConName
+       ; codeCon <- tcLookupTyCon codeTyConName
        ; let rep = getRuntimeRep exp_ty
-       ; return (mkAppTy m_ty (mkTyConApp texp [rep, exp_ty])) }
+       ; return (mkTyConApp codeCon [rep, m_ty, exp_ty]) }
   where
     err_msg ty
       = vcat [ text "Illegal polytype:" <+> ppr ty
@@ -620,10 +620,10 @@ tcNestedSplice pop_stage (TcPending ps_var lie_var q@(QuoteWrapper _ m_var)) spl
        ; expr' <- setStage pop_stage $
                   setConstraintVar lie_var $
                   tcCheckMonoExpr expr meta_exp_ty
-       ; untypeq <- tcLookupId unTypeQName
+       ; untype_code <- tcLookupId unTypeCodeName
        ; let expr'' = mkHsApp
                         (mkLHsWrap (applyQuoteWrapper q)
-                          (nlHsTyApp untypeq [rep, res_ty])) expr'
+                          (nlHsTyApp untype_code [rep, res_ty])) expr'
        ; ps <- readMutVar ps_var
        ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps)
 
diff --git a/docs/users_guide/exts/deriving_extra.rst b/docs/users_guide/exts/deriving_extra.rst
index 1352170af7..e1d63c4b65 100644
--- a/docs/users_guide/exts/deriving_extra.rst
+++ b/docs/users_guide/exts/deriving_extra.rst
@@ -528,7 +528,7 @@ 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`` and ``TExpQ a``), which can then be spliced into Haskell source
+type ``ExpQ`` and ``Code Q a``), which can then be spliced into Haskell source
 code.
 
 Here is an example of how one can derive ``Lift``:
diff --git a/docs/users_guide/exts/template_haskell.rst b/docs/users_guide/exts/template_haskell.rst
index f1319b904e..a33949a1f1 100644
--- a/docs/users_guide/exts/template_haskell.rst
+++ b/docs/users_guide/exts/template_haskell.rst
@@ -133,15 +133,15 @@ The :extension:`TemplateHaskellQuotes` extension is considered safe under
    is an arbitrary expression.
 
    A top-level typed expression splice can occur in place of an expression; the
-   spliced expression must have type ``Q (TExp a)``
+   spliced expression must have type ``Code Q a``
 
 -  A *typed* expression quotation is written as ``[|| ... ||]``, or
    ``[e|| ... ||]``, where the "..." is an expression; if the "..."
    expression has type ``a``, then the quotation has type
-   ``Quote m => m (TExp a)``.
+   ``Quote m => Code m a``.
 
-   Values of type ``TExp a`` may be converted to values of type ``Exp``
-   using the function ``unType :: TExp a -> Exp``.
+   It is possible to extract a value of type ``m Exp`` from ``Code m a``
+   using the ``unTypeCode :: Code m a -> m Exp`` function.
 
 -  A quasi-quotation can appear in a pattern, type, expression, or
    declaration context and is also written in Oxford brackets:
@@ -202,7 +202,7 @@ The :extension:`TemplateHaskellQuotes` extension is considered safe under
 
        class Lift t where
            lift :: Quote m => t -> m Exp
-           liftTyped :: Quote m => t -> m (TExp t)
+           liftTyped :: Quote m => t -> Code m t
 
    In general, if GHC sees an expression within Oxford brackets (e.g., ``[|
    foo bar |]``, then GHC looks up each name within the brackets. If a name
diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs
index 36529e54dc..2da2bd61c6 100644
--- a/libraries/template-haskell/Language/Haskell/TH.hs
+++ b/libraries/template-haskell/Language/Haskell/TH.hs
@@ -50,6 +50,8 @@ module Language.Haskell.TH(
 
         -- * Typed expressions
         TExp, unType,
+        Code(..), unTypeCode, unsafeCodeCoerce, hoistCode, bindCode,
+        bindCode_, joinCode, liftCode,
 
         -- * Names
         Name, NameSpace,        -- Abstract
diff --git a/libraries/template-haskell/Language/Haskell/TH/CodeDo.hs b/libraries/template-haskell/Language/Haskell/TH/CodeDo.hs
new file mode 100644
index 0000000000..8e69a833fb
--- /dev/null
+++ b/libraries/template-haskell/Language/Haskell/TH/CodeDo.hs
@@ -0,0 +1,20 @@
+-- | This module exists to work nicely with the QualifiedDo
+-- extension.
+-- @
+-- import qualified Language.Haskell.TH.CodeDo as Code
+-- myExample :: Monad m => Code m a -> Code m a -> Code m a
+-- myExample opt1 opt2 =
+--   Code.do
+--    x <- someSideEffect               -- This one is of type `M Bool`
+--    if x then opt1 else opt2
+-- @
+module Language.Haskell.TH.CodeDo((>>=), (>>)) where
+
+import Language.Haskell.TH.Syntax
+import Prelude(Monad)
+
+-- | Module over monad operator for 'Code'
+(>>=) :: Monad m => m a -> (a -> Code m b) -> Code m b
+(>>=) = bindCode
+(>>) :: Monad m => m a -> Code m b -> Code m b
+(>>)  = bindCode_
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index 7aa4761321..505b9125bc 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -18,7 +18,7 @@ module Language.Haskell.TH.Lib (
 
     -- * Library functions
     -- ** Abbreviations
-        InfoQ, ExpQ, TExpQ, DecQ, DecsQ, ConQ, TypeQ, KindQ,
+        InfoQ, ExpQ, TExpQ, CodeQ, DecQ, DecsQ, ConQ, TypeQ, KindQ,
         TyLitQ, CxtQ, PredQ, DerivClauseQ, MatchQ, ClauseQ, BodyQ, GuardQ,
         StmtQ, RangeQ, SourceStrictnessQ, SourceUnpackednessQ, BangQ,
         BangTypeQ, VarBangTypeQ, StrictTypeQ, VarStrictTypeQ, FieldExpQ, PatQ,
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
index c93cc6c3a8..cb19882a97 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
@@ -31,6 +31,7 @@ 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 a894ce8378..dac97c641f 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -374,6 +374,63 @@ be inferred (#8459).  Consider
 The splice will evaluate to (MkAge 3) and you can't add that to
 4::Int. So you can't coerce a (TExp Age) to a (TExp Int). -}
 
+-- Code constructor
+
+type role Code representational nominal   -- See Note [Role of TExp]
+newtype Code m (a :: TYPE (r :: RuntimeRep)) = Code
+  { examineCode :: m (TExp a) -- ^ Underlying monadic value
+  }
+
+-- | Unsafely convert an untyped code representation into a typed code
+-- representation.
+unsafeCodeCoerce :: forall (r :: RuntimeRep) (a :: TYPE r) m .
+                      Quote m => m Exp -> Code m a
+unsafeCodeCoerce m = Code (unsafeTExpCoerce m)
+
+-- | Lift a monadic action producing code into the typed 'Code'
+-- representation
+liftCode :: forall (r :: RuntimeRep) (a :: TYPE r) m . m (TExp a) -> Code m a
+liftCode = Code
+
+-- | Extract the untyped representation from the typed representation
+unTypeCode :: forall (r :: RuntimeRep) (a :: TYPE r) m . Quote m
+           => Code m a -> m Exp
+unTypeCode = unTypeQ . examineCode
+
+-- | Modify the ambient monad used during code generation. For example, you
+-- can use `hoistCode` to handle a state effect:
+-- @
+--  handleState :: Code (StateT Int Q) a -> Code Q a
+--  handleState = hoistCode (flip runState 0)
+-- @
+hoistCode :: forall m n (r :: RuntimeRep) (a :: TYPE r) . Monad m
+          => (forall x . m x -> n x) -> Code m a -> Code n a
+hoistCode f (Code a) = Code (f a)
+
+
+-- | Variant of (>>=) which allows effectful computations to be injected
+-- into code generation.
+bindCode :: forall m a (r :: RuntimeRep) (b :: TYPE r) . Monad m
+         => m a -> (a -> Code m b) -> Code m b
+bindCode q k = liftCode (q >>= examineCode . k)
+
+-- | Variant of (>>) which allows effectful computations to be injected
+-- into code generation.
+bindCode_ :: forall m a (r :: RuntimeRep) (b :: TYPE r) . Monad m
+          => m a -> Code m b -> Code m b
+bindCode_ q c = liftCode ( q >> examineCode c)
+
+-- | A useful combinator for embedding monadic actions into 'Code'
+-- @
+-- myCode :: ... => Code m a
+-- myCode = joinCode $ do
+--   x <- someSideEffect
+--   return (makeCodeWith x)
+-- @
+joinCode :: forall m (r :: RuntimeRep) (a :: TYPE r) . Monad m
+         => m (Code m a) -> Code m a
+joinCode = flip bindCode id
+
 ----------------------------------------------------
 -- Packaged versions for the programmer, hiding the Quasi-ness
 
@@ -758,107 +815,107 @@ class Lift (t :: TYPE r) where
   -- a splice.
   lift :: Quote m => t -> m Exp
   default lift :: (r ~ 'LiftedRep, Quote m) => t -> m Exp
-  lift = unTypeQ . liftTyped
+  lift = unTypeCode . liftTyped
 
   -- | Turn a value into a Template Haskell typed expression, suitable for use
   -- in a typed splice.
   --
   -- @since 2.16.0.0
-  liftTyped :: Quote m => t -> m (TExp t)
+  liftTyped :: Quote m => t -> Code m t
 
 
 -- If you add any instances here, consider updating test th/TH_Lift
 instance Lift Integer where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x = return (LitE (IntegerL x))
 
 instance Lift Int where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 -- | @since 2.16.0.0
 instance Lift Int# where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x = return (LitE (IntPrimL (fromIntegral (I# x))))
 
 instance Lift Int8 where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Lift Int16 where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Lift Int32 where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Lift Int64 where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 -- | @since 2.16.0.0
 instance Lift Word# where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x = return (LitE (WordPrimL (fromIntegral (W# x))))
 
 instance Lift Word where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Lift Word8 where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Lift Word16 where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Lift Word32 where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Lift Word64 where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Lift Natural where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x = return (LitE (IntegerL (fromIntegral x)))
 
 instance Integral a => Lift (Ratio a) where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x = return (LitE (RationalL (toRational x)))
 
 instance Lift Float where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x = return (LitE (RationalL (toRational x)))
 
 -- | @since 2.16.0.0
 instance Lift Float# where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x = return (LitE (FloatPrimL (toRational (F# x))))
 
 instance Lift Double where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x = return (LitE (RationalL (toRational x)))
 
 -- | @since 2.16.0.0
 instance Lift Double# where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x = return (LitE (DoublePrimL (toRational (D# x))))
 
 instance Lift Char where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x = return (LitE (CharL x))
 
 -- | @since 2.16.0.0
 instance Lift Char# where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x = return (LitE (CharPrimL (C# x)))
 
 instance Lift Bool where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
 
   lift True  = return (ConE trueName)
   lift False = return (ConE falseName)
@@ -868,24 +925,24 @@ instance Lift Bool where
 --
 -- @since 2.16.0.0
 instance Lift Addr# where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x
     = return (LitE (StringPrimL (map (fromIntegral . ord) (unpackCString# x))))
 
 instance Lift a => Lift (Maybe a) where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (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)
+  liftTyped x = unsafeCodeCoerce (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)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift xs = do { xs' <- mapM lift xs; return (ListE xs') }
 
 liftString :: Quote m => String -> m Exp
@@ -894,7 +951,7 @@ liftString s = return (LitE (StringL s))
 
 -- | @since 2.15.0.0
 instance Lift a => Lift (NonEmpty a) where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
 
   lift (x :| xs) = do
     x' <- lift x
@@ -903,77 +960,77 @@ instance Lift a => Lift (NonEmpty a) where
 
 -- | @since 2.15.0.0
 instance Lift Void where
-  liftTyped = pure . absurd
+  liftTyped = liftCode . absurd
   lift = pure . absurd
 
 instance Lift () where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift () = return (ConE (tupleDataName 0))
 
 instance (Lift a, Lift b) => Lift (a, b) where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift (a, b)
     = liftM TupE $ sequence $ map (fmap Just) [lift a, lift b]
 
 instance (Lift a, Lift b, Lift c) => Lift (a, b, c) where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift (a, b, c)
     = liftM TupE $ sequence $ map (fmap Just) [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)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift (a, b, c, d)
     = liftM TupE $ sequence $ map (fmap Just) [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)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift (a, b, c, d, e)
     = liftM TupE $ sequence $ map (fmap Just) [ 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)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift (a, b, c, d, e, f)
     = liftM TupE $ sequence $ map (fmap Just) [ 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)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift (a, b, c, d, e, f, g)
     = liftM TupE $ sequence $ map (fmap Just) [ 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)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift (# #) = return (ConE (unboxedTupleTypeName 0))
 
 -- | @since 2.16.0.0
 instance (Lift a) => Lift (# a #) where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift (# a #)
     = liftM UnboxedTupE $ sequence $ map (fmap Just) [lift a]
 
 -- | @since 2.16.0.0
 instance (Lift a, Lift b) => Lift (# a, b #) where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift (# a, b #)
     = liftM UnboxedTupE $ sequence $ map (fmap Just) [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)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift (# a, b, c #)
     = liftM UnboxedTupE $ sequence $ map (fmap Just) [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)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift (# a, b, c, d #)
     = liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b
                                                      , lift c, lift d ]
@@ -981,7 +1038,7 @@ instance (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)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift (# a, b, c, d, e #)
     = liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b
                                                      , lift c, lift d, lift e ]
@@ -989,7 +1046,7 @@ instance (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)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift (# a, b, c, d, e, f #)
     = liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b, lift c
                                                      , lift d, lift e, lift f ]
@@ -997,7 +1054,7 @@ instance (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)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift (# a, b, c, d, e, f, g #)
     = liftM UnboxedTupE $ sequence $ map (fmap Just) [ lift a, lift b, lift c
                                                      , lift d, lift e, lift f
@@ -1005,7 +1062,7 @@ instance (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)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x
     = case x of
         (# y | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 2
@@ -1014,7 +1071,7 @@ instance (Lift a, Lift b) => Lift (# a | b #) where
 -- | @since 2.16.0.0
 instance (Lift a, Lift b, Lift c)
       => Lift (# a | b | c #) where
-  liftTyped x = unsafeTExpCoerce (lift x)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x
     = case x of
         (# y | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 3
@@ -1024,7 +1081,7 @@ instance (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)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x
     = case x of
         (# y | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 4
@@ -1035,7 +1092,7 @@ instance (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)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x
     = case x of
         (# y | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 5
@@ -1047,7 +1104,7 @@ instance (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)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x
     = case x of
         (# y | | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 6
@@ -1060,7 +1117,7 @@ instance (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)
+  liftTyped x = unsafeCodeCoerce (lift x)
   lift x
     = case x of
         (# y | | | | | | #) -> UnboxedSumE <$> lift y <*> pure 1 <*> pure 7
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index 0b3aa8d079..eb72b11858 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -1,6 +1,9 @@
 # Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell)
 
 ## 2.17.0.0
+  * Typed Quotations now return a value of type `Code m a` (GHC Proposal #195).
+    The main motiviation is to make writing instances easier and make it easier to
+    store `Code` values in type-indexed maps.
 
   * Implement Overloaded Quotations (GHC Proposal #246). This patch modifies a
     few fundamental things in the API. All the library combinators are generalised
diff --git a/libraries/template-haskell/template-haskell.cabal.in b/libraries/template-haskell/template-haskell.cabal.in
index fc89bf69c6..34984c00bb 100644
--- a/libraries/template-haskell/template-haskell.cabal.in
+++ b/libraries/template-haskell/template-haskell.cabal.in
@@ -48,7 +48,7 @@ Library
         Language.Haskell.TH.Quote
         Language.Haskell.TH.Syntax
         Language.Haskell.TH.LanguageExtensions
-
+        Language.Haskell.TH.CodeDo
         Language.Haskell.TH.Lib.Internal
 
     other-modules:
diff --git a/libraries/text b/libraries/text
-Subproject 7f1137277f82fb424c678f8ae62886143aad4a7
+Subproject 80cb9ee2eb7141171171318bbd6760fe8001252
diff --git a/testsuite/tests/deriving/should_compile/drv-empty-data.stderr b/testsuite/tests/deriving/should_compile/drv-empty-data.stderr
index cb6a89b226..9d7cb859bd 100644
--- a/testsuite/tests/deriving/should_compile/drv-empty-data.stderr
+++ b/testsuite/tests/deriving/should_compile/drv-empty-data.stderr
@@ -46,7 +46,9 @@ 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)
+    Language.Haskell.TH.Syntax.liftTyped z
+      = Language.Haskell.TH.Syntax.unsafeCodeCoerce
+          (GHC.Base.pure (case z of))
   
   $tVoid :: Data.Data.DataType
   $tVoid = Data.Data.mkDataType "Void" []
diff --git a/testsuite/tests/parser/should_compile/Proposal229f_instances.hs b/testsuite/tests/parser/should_compile/Proposal229f_instances.hs
index 2bd5a8ee19..357a53fcb4 100644
--- a/testsuite/tests/parser/should_compile/Proposal229f_instances.hs
+++ b/testsuite/tests/parser/should_compile/Proposal229f_instances.hs
@@ -8,8 +8,8 @@ import Data.String
 import Language.Haskell.TH
 import Language.Haskell.TH.Syntax
 
-instance IsList (Q (TExp String)) where
-  type Item (Q (TExp String)) = Char
+instance IsList (Code Q String) where
+  type Item (Code Q String) = Char
   fromList = liftTyped
   toList = undefined
 
@@ -18,7 +18,7 @@ instance IsList (Q Exp) where
   fromList = lift
   toList = undefined
 
-instance IsString (Q (TExp String)) where
+instance IsString (Code Q String) where
   fromString = liftTyped
 
 instance IsString (Q Exp) where
diff --git a/testsuite/tests/partial-sigs/should_compile/TypedSplice.hs b/testsuite/tests/partial-sigs/should_compile/TypedSplice.hs
index ef09c4d093..bc886d5cf3 100644
--- a/testsuite/tests/partial-sigs/should_compile/TypedSplice.hs
+++ b/testsuite/tests/partial-sigs/should_compile/TypedSplice.hs
@@ -5,5 +5,5 @@ module TypedSplice where
 
 import Language.Haskell.TH
 
-metaExp :: Q (TExp (Bool -> Bool))
+metaExp :: Code Q (Bool -> Bool)
 metaExp = [|| not :: _ -> _b ||]
diff --git a/testsuite/tests/partial-sigs/should_compile/TypedSplice.stderr b/testsuite/tests/partial-sigs/should_compile/TypedSplice.stderr
index 49ecb6c911..2ae23b0d3d 100644
--- a/testsuite/tests/partial-sigs/should_compile/TypedSplice.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/TypedSplice.stderr
@@ -5,7 +5,7 @@ TypedSplice.hs:9:22: warning: [-Wpartial-type-signatures (in -Wdefault)]
       In an expression type signature: _ -> _b
       In the Template Haskell quotation [|| not :: _ -> _b ||]
     • Relevant bindings include
-        metaExp :: Q (TExp (Bool -> Bool)) (bound at TypedSplice.hs:9:1)
+        metaExp :: Code Q (Bool -> Bool) (bound at TypedSplice.hs:9:1)
 
 TypedSplice.hs:9:27: warning: [-Wpartial-type-signatures (in -Wdefault)]
     • Found type wildcard ‘_b’ standing for ‘Bool’
@@ -13,4 +13,4 @@ TypedSplice.hs:9:27: warning: [-Wpartial-type-signatures (in -Wdefault)]
       In the Template Haskell quotation [|| not :: _ -> _b ||]
       In the expression: [|| not :: _ -> _b ||]
     • Relevant bindings include
-        metaExp :: Q (TExp (Bool -> Bool)) (bound at TypedSplice.hs:9:1)
+        metaExp :: Code Q (Bool -> Bool) (bound at TypedSplice.hs:9:1)
diff --git a/testsuite/tests/quotes/T17857.hs b/testsuite/tests/quotes/T17857.hs
index f64f0ce753..f2918580a5 100644
--- a/testsuite/tests/quotes/T17857.hs
+++ b/testsuite/tests/quotes/T17857.hs
@@ -7,4 +7,4 @@ import Language.Haskell.TH.Syntax
 data T = MkT deriving Data
 instance Lift T where
   lift = liftData
-  liftTyped = unsafeTExpCoerce . lift
+  liftTyped = unsafeCodeCoerce . lift
diff --git a/testsuite/tests/th/T10945.stderr b/testsuite/tests/th/T10945.stderr
index 09e1afa877..1c7a0f238d 100644
--- a/testsuite/tests/th/T10945.stderr
+++ b/testsuite/tests/th/T10945.stderr
@@ -1,9 +1,9 @@
 
 T10945.hs:7:4: error:
     • Couldn't match type: [Dec]
-                     with: TExp DecsQ
-      Expected: Q (TExp DecsQ)
-        Actual: Q [Dec]
+                     with: Q [Dec]
+      Expected: Code Q DecsQ
+        Actual: Code Q [Dec]
     • In the expression:
         return
           [SigD
diff --git a/testsuite/tests/th/T11452.stderr b/testsuite/tests/th/T11452.stderr
index 88e9af57fc..2de5aa0a0f 100644
--- a/testsuite/tests/th/T11452.stderr
+++ b/testsuite/tests/th/T11452.stderr
@@ -8,10 +8,10 @@ T11452.hs:6:12: error:
 
 T11452.hs:6:14: error:
     • Couldn't match type ‘p0’ with ‘forall a. a -> a’
-      Expected: Language.Haskell.TH.Syntax.Q
-                  (Language.Haskell.TH.Syntax.TExp ((forall a. a -> a) -> ()))
-        Actual: Language.Haskell.TH.Syntax.Q
-                  (Language.Haskell.TH.Syntax.TExp (p0 -> ()))
+      Expected: Language.Haskell.TH.Syntax.Code
+                  Language.Haskell.TH.Syntax.Q ((forall a. a -> a) -> ())
+        Actual: Language.Haskell.TH.Syntax.Code
+                  Language.Haskell.TH.Syntax.Q (p0 -> ())
       Cannot instantiate unification variable ‘p0’
       with a type involving polytypes: forall a. a -> a
     • In the Template Haskell quotation [|| \ _ -> () ||]
diff --git a/testsuite/tests/th/T15471A.hs b/testsuite/tests/th/T15471A.hs
index 2bf5cc8952..03219be333 100644
--- a/testsuite/tests/th/T15471A.hs
+++ b/testsuite/tests/th/T15471A.hs
@@ -6,9 +6,9 @@ import Language.Haskell.TH
 foo1 x = x
 
 
-test_foo :: Q (TExp (a -> a))
+test_foo :: Code Q (a -> a)
 test_foo = [|| foo1 ||]
 
 
-list_foo :: Q (TExp a) -> Q (TExp [a])
+list_foo :: Code Q a -> Code Q [a]
 list_foo x = [|| [ $$x, $$x ] ||]
diff --git a/testsuite/tests/th/T15843.hs b/testsuite/tests/th/T15843.hs
index 9f807a8cb6..c08bd3e5e8 100644
--- a/testsuite/tests/th/T15843.hs
+++ b/testsuite/tests/th/T15843.hs
@@ -13,12 +13,12 @@ main = do
   mapM_ (\q -> runQ q >>= ppr_and_show)
         [first_of_2, second_of_2, empty_2, full_2, third_of_3]
 
-  mapM_ (\q -> runQ (fmap unType q) >>= ppr_and_show)
+  mapM_ (\q -> (runQ (unTypeCode q)) >>= ppr_and_show)
         [first_of_2_T, second_of_2_T]
 
-  runQ (fmap unType empty_2_T) >>= ppr_and_show
-  runQ (fmap unType full_2_T) >>= ppr_and_show
-  runQ (fmap unType third_of_3_T) >>= ppr_and_show
+  runQ (unTypeCode empty_2_T) >>= ppr_and_show
+  runQ (unTypeCode full_2_T) >>= ppr_and_show
+  runQ (unTypeCode third_of_3_T) >>= ppr_and_show
 
   print $ "(909,) applied to 'c' should be (909, 'c') ===> "
             ++ (show $ (909, 'c') == ($first_of_2 'c'))
diff --git a/testsuite/tests/th/T16195A.hs b/testsuite/tests/th/T16195A.hs
index b79aff77af..abc6b01376 100644
--- a/testsuite/tests/th/T16195A.hs
+++ b/testsuite/tests/th/T16195A.hs
@@ -3,11 +3,11 @@ module T16195A where
 
 import Language.Haskell.TH
 
-foo :: Q (TExp (IO ()))
+foo :: Code Q (IO ())
 foo = [|| return () ||]
 
-showC :: Q (TExp (() -> String))
+showC :: Code Q (() -> String)
 showC = [|| show ||]
 
-unitC :: Q (TExp ())
+unitC :: Code Q ()
 unitC = [|| () ||]
diff --git a/testsuite/tests/th/T18102b_aux.hs b/testsuite/tests/th/T18102b_aux.hs
index f6badf02d7..378f53fa42 100644
--- a/testsuite/tests/th/T18102b_aux.hs
+++ b/testsuite/tests/th/T18102b_aux.hs
@@ -7,5 +7,5 @@ import Language.Haskell.TH.Syntax
 ifThenElse :: Bool -> Int -> Int -> Int
 ifThenElse _ a b = a+b
 
-intQuote :: Q (TExp Int)
+intQuote :: Code Q Int
 intQuote = [|| if True then 10 else 15 ||]
diff --git a/testsuite/tests/th/T18121.hs b/testsuite/tests/th/T18121.hs
index f9efdf378b..1f51b61e73 100644
--- a/testsuite/tests/th/T18121.hs
+++ b/testsuite/tests/th/T18121.hs
@@ -3,5 +3,5 @@ module Bug where
 
 import Language.Haskell.TH
 
-sapply :: Q (TExp (a -> b)) -> Q (TExp a) -> Q (TExp b)
+sapply :: Quote m => Code m (a -> b) -> Code m a -> Code m b
 sapply cf cx = [|| $$cf $$cx ||]
diff --git a/testsuite/tests/th/T8577.stderr b/testsuite/tests/th/T8577.stderr
index 595338e07e..9c83d3c657 100644
--- a/testsuite/tests/th/T8577.stderr
+++ b/testsuite/tests/th/T8577.stderr
@@ -1,8 +1,8 @@
 
 T8577.hs:9:11: error:
     • Couldn't match type ‘Int’ with ‘Bool’
-      Expected: Q (TExp (A Bool))
-        Actual: Q (TExp (A Int))
+      Expected: Code Q (A Bool)
+        Actual: Code Q (A Int)
     • In the expression: y
       In the Template Haskell splice $$(y)
       In the expression: $$(y)
diff --git a/testsuite/tests/th/T8577a.hs b/testsuite/tests/th/T8577a.hs
index 807350c3a2..425645f877 100644
--- a/testsuite/tests/th/T8577a.hs
+++ b/testsuite/tests/th/T8577a.hs
@@ -4,8 +4,8 @@ import Language.Haskell.TH
 
 data A a = A
 
-x :: Q (TExp (A a))
+x :: Code Q (A a)
 x = [|| A ||]
 
-y :: Q (TExp (A Int))
+y :: Code Q (A Int)
 y = x
diff --git a/testsuite/tests/th/TH_StringLift.hs b/testsuite/tests/th/TH_StringLift.hs
index 334ba14353..3e12b8a5c8 100644
--- a/testsuite/tests/th/TH_StringLift.hs
+++ b/testsuite/tests/th/TH_StringLift.hs
@@ -3,7 +3,7 @@ module TH_StringLift where
 
 import Language.Haskell.TH.Syntax
 
-foo :: Quote m => String -> m (TExp String)
+foo :: Quote m => String -> Code m String
 foo x = [|| x ||]
 
 foo2 :: Quote m => String -> m Exp
diff --git a/testsuite/tests/th/TH_reifyLocalDefs.hs b/testsuite/tests/th/TH_reifyLocalDefs.hs
index 0bfc90fe1a..53a7f8b665 100644
--- a/testsuite/tests/th/TH_reifyLocalDefs.hs
+++ b/testsuite/tests/th/TH_reifyLocalDefs.hs
@@ -29,8 +29,8 @@ main = print (f 1 "", g 'a' 2, h True 3)
                 )
              , xg :: Char
              )
-    h xh y = ( $$(do printTypeOf("xh")
-                     [|| y :: Int ||]
+    h xh y = ( $$(liftCode $ do printTypeOf("xh")
+                                examineCode [|| y :: Int ||]
                  )
              , xh :: Bool
              )
diff --git a/testsuite/tests/th/overloaded/T17839.hs b/testsuite/tests/th/overloaded/T17839.hs
index 9946811d90..785aa914ca 100644
--- a/testsuite/tests/th/overloaded/T17839.hs
+++ b/testsuite/tests/th/overloaded/T17839.hs
@@ -16,7 +16,7 @@ import Data.Functor.Identity
 
 type LetT m a = WriterT [Locus] m a
 
-type Code m a = m (TExp a)
+type MCode m a = m (TExp a)
 
 type LetCode m a = LetT m (TExp a)
 
@@ -29,7 +29,7 @@ instance (Monoid w, Quote m) => Quote (StateT w m) where
   newName x = W.lift (newName x)
 
 
-locus :: (Locus -> LetCode m a) -> Code m a
+locus :: (Locus -> LetCode m a) -> MCode m a
 locus = undefined
 
 newTypedName :: Quote m => m (TExp a)
@@ -38,15 +38,15 @@ newTypedName = do
   return (TExp (VarE n))
 
 
-gen :: Quote m => Locus -> (Code Identity (a -> b) -> LetCode m a -> LetCode m b) -> LetCode m (a -> b)
+gen :: Quote m => Locus -> (MCode Identity (a -> b) -> LetCode m a -> LetCode m b) -> LetCode m (a -> b)
 gen l f = do
   n <- newTypedName
-  [|| \a -> $$(f (Identity n) [|| a ||]) ||]
+  examineCode [|| \a -> $$(liftCode $ f (Identity n) (examineCode [|| a ||])) ||]
 
 
 mrfix :: forall a b m r . (Monad m, Ord a, Quote m)
-      => (forall m . (a -> Code m (b -> r)) -> (a -> Code m b -> Code m r))
-      -> (a -> Code m (b -> r))
+      => (forall m . (a -> MCode m (b -> r)) -> (a -> MCode m b -> MCode m r))
+      -> (a -> MCode m (b -> r))
 mrfix f x =
   flip evalStateT Map.empty $
     locus $ \locus -> do
diff --git a/testsuite/tests/th/overloaded/TH_overloaded_constraints.hs b/testsuite/tests/th/overloaded/TH_overloaded_constraints.hs
index 565ef41c1d..6e4d430e7a 100644
--- a/testsuite/tests/th/overloaded/TH_overloaded_constraints.hs
+++ b/testsuite/tests/th/overloaded/TH_overloaded_constraints.hs
@@ -22,11 +22,11 @@ dq = [| 5 |]
 top_level :: (C m, D m, Quote m) => m Exp
 top_level = [| $cq + $dq |]
 
-cqt :: (C m, Quote m) => m (TExp Int)
+cqt :: (C m, Quote m) => Code m Int
 cqt = [|| 5 ||]
 
-dqt :: (D m, Quote m) => m (TExp Int)
+dqt :: (D m, Quote m) => Code m Int
 dqt = [|| 5 ||]
 
-top_level_t :: (C m, D m, Quote m) => m (TExp Int)
+top_level_t :: (C m, D m, Quote m) => Code m Int
 top_level_t = [|| $$cqt + $$dqt ||]
diff --git a/testsuite/tests/th/overloaded/TH_overloaded_csp.hs b/testsuite/tests/th/overloaded/TH_overloaded_csp.hs
index c87707c01e..ea74e00d24 100644
--- a/testsuite/tests/th/overloaded/TH_overloaded_csp.hs
+++ b/testsuite/tests/th/overloaded/TH_overloaded_csp.hs
@@ -14,5 +14,5 @@ instance Quote Identity where
 
 main = do
   print $ runIdentity ((\x -> [| x |]) ())
-  print $ unType $ runIdentity ((\x -> [|| x ||]) ())
+  print $ runIdentity $ unTypeCode ((\x -> [|| x ||]) ())
 
diff --git a/testsuite/tests/th/overloaded/TH_overloaded_extract.hs b/testsuite/tests/th/overloaded/TH_overloaded_extract.hs
index 23c5ac5257..299b4f045d 100644
--- a/testsuite/tests/th/overloaded/TH_overloaded_extract.hs
+++ b/testsuite/tests/th/overloaded/TH_overloaded_extract.hs
@@ -19,5 +19,5 @@ main = do
   print $ runIdentity [d| data Foo = Foo |]
   print $ runIdentity [p| () |]
   print $ runIdentity [t| [Int] |]
-  print $ unType $ runIdentity [|| (+1) ||]
+  print $ runIdentity $ unTypeCode [|| (+1) ||]