[commit: ghc] wip/th-new: Change the types of typed brackets and splices. (bf0a415)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/th-new
Link       : http://ghc.haskell.org/trac/ghc/changeset/bf0a41591d014eca971e7f1f6cf29d146281ca7a/ghc

>---------------------------------------------------------------

commit bf0a41591d014eca971e7f1f6cf29d146281ca7a
Author: Geoffrey Mainland <mainland at apeiron.net>
Date:   Tue May 21 15:07:09 2013 +0100

    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.


>---------------------------------------------------------------

bf0a41591d014eca971e7f1f6cf29d146281ca7a
 compiler/deSugar/DsMeta.hs      |   14 +++++++++++---
 compiler/typecheck/TcSplice.lhs |   14 ++++++++------
 2 files changed, 19 insertions(+), 9 deletions(-)

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 24d7a1a..51544e5 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"
@@ -2024,6 +2025,8 @@ templateHaskellNames = [
     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
     liftStringName,
     unTypeName,
+    unTypeQName,
+    unsafeTExpCoerceName,
 
     -- Lit
     charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
@@ -2161,7 +2164,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
@@ -2174,6 +2178,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 -----------------------
@@ -2518,7 +2524,7 @@ tExpTyConKey            = mkPreludeTyConUnique 230
 
 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
@@ -2530,6 +2536,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 ba0646f..bce332f 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -383,8 +383,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 _ _
@@ -422,10 +422,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}
 
 
@@ -482,8 +484,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 ()