Change the types of typed brackets and splices.

The essence of this change is that a TExp a now wraps a TH.Exp instead of a
TH.ExpQ. This means:

 * A typed bracket [||...||] now has type Q (TExp tau), where tau is the type of
   the expression in the bracket.

 * A typed splice $(...)  must contain a value of type Q (TExp tau), and has
   type tau.

Previously, typed brackets had type TExp tau, and typed splices had to contain a
value of type TExp tau.

2 files changed, 19 insertions, 9 deletions

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 28dc87d1d5..8cb7036675 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -19,7 +19,8 @@ module DsMeta( dsBracket,
                decQTyConName, decsQTyConName, typeQTyConName,
                decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,
                quoteExpName, quotePatName, quoteDecName, quoteTypeName,
-               tExpTyConName, tExpDataConName, unTypeName
+               tExpTyConName, tExpDataConName, unTypeName, unTypeQName,
+               unsafeTExpCoerceName
                 ) where
 
 #include "HsVersions.h"
@@ -1909,6 +1910,8 @@ templateHaskellNames = [
     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
     liftStringName,
     unTypeName,
+    unTypeQName,
+    unsafeTExpCoerceName,
 
     -- Lit
     charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
@@ -2040,7 +2043,8 @@ tExpTyConName     = thTc (fsLit "TExp")         tExpTyConKey
 
 returnQName, bindQName, sequenceQName, newNameName, liftName,
     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
-    mkNameLName, liftStringName, unTypeName :: Name
+    mkNameLName, liftStringName, unTypeName, unTypeQName,
+    unsafeTExpCoerceName :: Name
 returnQName    = thFun (fsLit "returnQ")   returnQIdKey
 bindQName      = thFun (fsLit "bindQ")     bindQIdKey
 sequenceQName  = thFun (fsLit "sequenceQ") sequenceQIdKey
@@ -2053,6 +2057,8 @@ mkNameG_dName  = thFun (fsLit "mkNameG_d")  mkNameG_dIdKey
 mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
 mkNameLName    = thFun (fsLit "mkNameL")    mkNameLIdKey
 unTypeName     = thFun (fsLit "unType")     unTypeIdKey
+unTypeQName    = thFun (fsLit "unTypeQ")    unTypeQIdKey
+unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey
 
 
 -------------------- TH.Lib -----------------------
@@ -2376,7 +2382,7 @@ tExpTyConKey            = mkPreludeTyConUnique 228
 
 returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
     mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
-    mkNameLIdKey, unTypeIdKey :: Unique
+    mkNameLIdKey, unTypeIdKey, unTypeQIdKey, unsafeTExpCoerceIdKey :: Unique
 returnQIdKey        = mkPreludeMiscIdUnique 200
 bindQIdKey          = mkPreludeMiscIdUnique 201
 sequenceQIdKey      = mkPreludeMiscIdUnique 202
@@ -2388,6 +2394,8 @@ mkNameG_dIdKey       = mkPreludeMiscIdUnique 207
 mkNameG_tcIdKey      = mkPreludeMiscIdUnique 208
 mkNameLIdKey         = mkPreludeMiscIdUnique 209
 unTypeIdKey          = mkPreludeMiscIdUnique 210
+unTypeQIdKey         = mkPreludeMiscIdUnique 211
+unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 212
 
 
 -- data Lit = ...
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index a7abfbb1d8..041df8413a 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -380,8 +380,8 @@ tcBracket brack ps res_ty
            ; meta_ty <- tcTExpTy any_ty
            ; ps' <- readMutVar ps_ref
            ; co <- unifyType meta_ty res_ty
-           ; d <- tcLookupDataCon tExpDataConName
-           ; return (mkHsWrapCo co (unLoc (mkHsConApp d [any_ty] [HsBracketOut brack ps'])))
+           ; texpco <- tcLookupId unsafeTExpCoerceName
+           ; return (mkHsWrapCo co (unLoc (mkHsApp (nlHsTyApp texpco [any_ty]) (noLoc (HsBracketOut brack ps')))))
            }
 
     tc_bracket _ _
@@ -419,10 +419,12 @@ tcPendingSplice (PendingRnDeclSplice n expr)
 tcPendingSplice (PendingTcSplice _ expr) 
   = pprPanic "tcPendingSplice: PendingTcSplice" (ppr expr)
 
+-- Takes a type tau and returns the type Q (TExp tau)
 tcTExpTy :: TcType -> TcM TcType
 tcTExpTy tau = do
-    t <- tcLookupTyCon tExpTyConName
-    return (mkTyConApp t [tau])
+    q <- tcLookupTyCon qTyConName
+    texp <- tcLookupTyCon tExpTyConName
+    return (mkTyConApp q [mkTyConApp texp [tau]])
 \end{code}
 
 
@@ -479,8 +481,8 @@ tcSpliceExpr splice@(HsSplice isTypedSplice name expr) res_ty
            ; expr' <- setStage pop_stage $
                       setConstraintVar lie_var $
                       tcMonoExpr expr meta_exp_ty
-           ; unt <- tcLookupId unTypeName
-           ; let expr'' = mkHsApp (nlHsTyApp unt [res_ty]) expr'
+           ; untypeq <- tcLookupId unTypeQName
+           ; let expr'' = mkHsApp (nlHsTyApp untypeq [res_ty]) expr'
            ; ps <- readMutVar ps_var
            ; writeMutVar ps_var (PendingTcSplice name expr'' : ps)
            ; return ()