%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-\section[TcSplice]{Template Haskell splices}
+
+TcSplice: Template Haskell splices
\begin{code}
module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket ) where
#include "HsVersions.h"
-import HscMain ( compileExpr )
-import TcRnDriver ( tcTopSrcDecls )
+import HscMain
+import TcRnDriver
-- These imports are the reason that TcSplice
-- is very high up the module hierarchy
-import qualified Language.Haskell.TH as TH
--- THSyntax gives access to internal functions and data types
-import qualified Language.Haskell.TH.Syntax as TH
-
-import HsSyn ( HsBracket(..), HsExpr(..), HsSplice(..), LHsExpr, LHsDecl,
- HsType, LHsType )
-import Convert ( convertToHsExpr, convertToHsDecls, convertToHsType, thRdrName )
-import RnExpr ( rnLExpr )
-import RnEnv ( lookupFixityRn, lookupSrcOcc_maybe, lookupImportedName )
-import RdrName ( RdrName, lookupLocalRdrEnv, isSrcRdrName )
-import RnTypes ( rnLHsType )
-import TcExpr ( tcMonoExpr )
-import TcHsSyn ( mkHsDictLet, zonkTopLExpr )
-import TcSimplify ( tcSimplifyTop, tcSimplifyBracket )
-import TcUnify ( boxyUnify, unBox )
-import TcType ( TcType, TcKind, BoxyRhoType, liftedTypeKind, mkAppTy, tcSplitSigmaTy )
-import TcEnv ( spliceOK, tcMetaTy, bracketOK )
-import TcMType ( newFlexiTyVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType )
-import TcHsType ( tcHsSigType, kcHsType )
-import TcIface ( tcImportDecl )
-import TypeRep ( Type(..), PredType(..), TyThing(..) ) -- For reification
-import PrelNames ( thFAKE )
-import Name ( Name, NamedThing(..), nameOccName, nameModule, isExternalName,
- nameIsLocalOrFrom )
-import NameEnv ( lookupNameEnv )
-import HscTypes ( lookupType, ExternalPackageState(..), emptyModDetails )
+import HsSyn
+import Convert
+import RnExpr
+import RnEnv
+import RdrName
+import RnTypes
+import TcExpr
+import TcHsSyn
+import TcSimplify
+import TcUnify
+import TcType
+import TcEnv
+import TcMType
+import TcHsType
+import TcIface
+import TypeRep
+import Name
+import NameEnv
+import HscTypes
import OccName
-import Var ( Id, TyVar, idType )
-import Module ( moduleString )
+import Var
+import Module
import TcRnMonad
-import IfaceEnv ( lookupOrig )
-import Class ( Class, classExtraBigSig )
-import TyCon ( TyCon, tyConTyVars, synTyConDefn,
- isSynTyCon, isNewTyCon, tyConDataCons, isPrimTyCon, isFunTyCon,
- tyConArity, tyConStupidTheta, isUnLiftedTyCon )
-import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConStrictMarks,
- dataConName, dataConFieldLabels, dataConWrapId, dataConIsInfix,
- isVanillaDataCon )
-import Id ( idName, globalIdDetails )
-import IdInfo ( GlobalIdDetails(..) )
-import TysWiredIn ( mkListTy )
-import DsMeta ( expQTyConName, typeQTyConName, decTyConName, qTyConName, nameTyConName )
-import ErrUtils ( Message )
-import SrcLoc ( SrcSpan, noLoc, unLoc, getLoc )
+import IfaceEnv
+import Class
+import TyCon
+import DataCon
+import Id
+import IdInfo
+import TysWiredIn
+import DsMeta
+import DsExpr
+import DsMonad hiding (Splice)
+import ErrUtils
+import SrcLoc
import Outputable
-import Unique ( Unique, Uniquable(..), getKey, mkUniqueGrimily )
-
-import BasicTypes ( StrictnessMark(..), Fixity(..), FixityDirection(..) )
-import Panic ( showException )
-import FastString ( LitString )
+import Unique
+import PackageConfig
+import BasicTypes
+import Panic
+import FastString
-import GHC.Base ( unsafeCoerce#, Int#, Int(..) ) -- Should have a better home in the module hierarchy
-import Monad ( liftM )
+import qualified Language.Haskell.TH as TH
+-- THSyntax gives access to internal functions and data types
+import qualified Language.Haskell.TH.Syntax as TH
-#ifdef GHCI
-import FastString ( mkFastString )
-#endif
+import GHC.Exts ( unsafeCoerce#, Int#, Int(..) )
+import Control.Monad ( liftM )
\end{code}
%************************************************************************
\begin{code}
-tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr Id)
+tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
tcBracket brack res_ty
= getStage `thenM` \ level ->
case bracketOK level of {
-> LHsExpr Id -- Of type X
-> TcM hs_syn -- Of type t
runMeta convert expr
- = do { hsc_env <- getTopEnv
- ; tcg_env <- getGblEnv
- ; this_mod <- getModule
- ; let type_env = tcg_type_env tcg_env
- rdr_env = tcg_rdr_env tcg_env
+ = do { -- Desugar
+ ds_expr <- initDsTc (dsLExpr expr)
-- Compile and link it; might fail if linking fails
+ ; hsc_env <- getTopEnv
+ ; src_span <- getSrcSpanM
; either_hval <- tryM $ ioToTcRn $
- HscMain.compileExpr
- hsc_env this_mod
- rdr_env type_env expr
+ HscMain.compileExpr hsc_env src_span ds_expr
; case either_hval of {
Left exn -> failWithTc (mk_msg "compile and link" exn) ;
Right hval -> do
-- We also do the TH -> HS syntax conversion inside the same
-- exception-cacthing thing so that if there are any lurking
-- exceptions in the data structure returned by hval, we'll
- -- encounter them inside the tryALlM
+ -- encounter them inside the try
either_tval <- tryAllM $ do
{ th_syn <- TH.runQ (unsafeCoerce# hval)
; case convert (getLoc expr) th_syn of
qReport True msg = addErr (text msg)
qReport False msg = addReport (text msg)
- qCurrentModule = do { m <- getModule; return (moduleString m) }
+ qCurrentModule = do { m <- getModule;
+ return (moduleNameString (moduleName m)) }
+ -- ToDo: is throwing away the package name ok here?
+
qReify v = reify v
- qRecover = recoverM
+
+ -- For qRecover, discard error messages if
+ -- the recovery action is chosen. Otherwise
+ -- we'll only fail higher up. c.f. tryTcLIE_
+ qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
+ ; case mb_res of
+ Just val -> do { addMessages msgs -- There might be warnings
+ ; return val }
+ Nothing -> recover -- Discard all msgs
+ }
qRunIO io = ioToTcRn io
\end{code}
; reifyThing thing
}
where
- ppr_ns (TH.Name _ (TH.NameG TH.DataName mod)) = text "data"
- ppr_ns (TH.Name _ (TH.NameG TH.TcClsName mod)) = text "tc"
- ppr_ns (TH.Name _ (TH.NameG TH.VarName mod)) = text "var"
+ ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
+ ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
+ ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
lookupThName :: TH.Name -> TcM Name
lookupThName th_name@(TH.Name occ flavour)
else do -- It's imported
{ (eps,hpt) <- getEpsAndHpt
- ; case lookupType hpt (eps_PTE eps) name of
+ ; dflags <- getDOpts
+ ; case lookupType dflags hpt (eps_PTE eps) name of
Just thing -> return (AGlobal thing)
Nothing -> do { thing <- tcImportDecl name
; return (AGlobal thing) }
; fix <- reifyFixity name
; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
-reifyThing (ATcId id _ _)
- = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
- -- though it may be incomplete
+reifyThing (ATcId {tct_id = id, tct_type = ty})
+ = do { ty1 <- zonkTcType ty -- Make use of all the info we have, even
+ -- though it may be incomplete
; ty2 <- reifyType ty1
; fix <- reifyFixity (idName id)
; return (TH.VarI (reifyName id) ty2 Nothing fix) }
| isFunTyCon tc = return (TH.PrimTyConI (reifyName tc) 2 False)
| isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
| isSynTyCon tc
- = do { let (tvs, rhs) = synTyConDefn tc
- ; rhs' <- reifyType rhs
- ; return (TH.TyConI $ TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
+ = do { let (tvs, rhs) = synTyConDefn tc
+ ; rhs' <- reifyType rhs
+ ; return (TH.TyConI $
+ TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
reifyTyCon tc
= do { cxt <- reifyCxt (tyConStupidTheta tc)
; ops <- mapM reify_op op_stuff
; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
where
- (tvs, fds, theta, _, op_stuff) = classExtraBigSig cls
+ (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
fds' = map reifyFunDep fds
reify_op (op, _) = do { ty <- reifyType (idType op)
; return (TH.SigD (reifyName op) ty) }
------------------------------
reifyName :: NamedThing n => n -> TH.Name
reifyName thing
- | isExternalName name = mk_varg mod occ_str
+ | isExternalName name = mk_varg pkg_str mod_str occ_str
| otherwise = TH.mkNameU occ_str (getKey (getUnique name))
-- Many of the things we reify have local bindings, and
-- NameL's aren't supposed to appear in binding positions, so
-- have free variables, we may need to generate NameL's for them.
where
name = getName thing
- mod = moduleString (nameModule name)
+ mod = nameModule name
+ pkg_str = packageIdString (modulePackageId mod)
+ mod_str = moduleNameString (moduleName mod)
occ_str = occNameString occ
occ = nameOccName name
mk_varg | OccName.isDataOcc occ = TH.mkNameG_d