Commit c6033dcd authored by gmainland's avatar gmainland
Browse files

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.
parent cb441238
......@@ -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 = ...
......
......@@ -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 ()
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment