Use a newtype `Code` for the return type of typed quotations (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.

3 files changed, 42 insertions, 51 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)