Repository : ssh://g...@git.haskell.org/ghc
On branch : wip/th-new
Link :
http://ghc.haskell.org/trac/ghc/changeset/c6033dcda6ab53979f4a1dde331eacd38a2614cf/ghc
>---------------------------------------------------------------
commit c6033dcda6ab53979f4a1dde331eacd38a2614cf
Author: Geoffrey Mainland <mainl...@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.
>---------------------------------------------------------------
c6033dcda6ab53979f4a1dde331eacd38a2614cf
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 d5f6655..d64b456 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -382,8 +382,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 _ _
@@ -421,10 +421,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}
@@ -481,8 +483,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 ()
_______________________________________________
ghc-commits mailing list
ghc-commits@haskell.org
http://www.haskell.org/mailman/listinfo/ghc-commits
