X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=a99bf8b9e24ef1f5247cc31abbc8d149d21dad3c;hb=84923cc7de2a93c22a2f72daf9ac863959efae13;hp=beb72f193278b25f81b006e010c6ccf178a18739;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index beb72f1..a99bf8b 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -1,75 +1,69 @@ % +% (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 DynFlags +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} @@ -83,6 +77,7 @@ import FastString ( mkFastString ) tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId) kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind) + -- None of these functions add constraints to the LIE #ifndef GHCI tcSpliceExpr n e ty = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e) @@ -97,7 +92,7 @@ tcSpliceDecls e = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e) %************************************************************************ \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 { @@ -368,17 +363,17 @@ runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn) -> 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 +#if defined(GHCI) && defined(DEBUGGER) + ds_expr <- unsetOptM Opt_Debugging $ initDsTc (dsLExpr expr) +#else + ds_expr <- initDsTc (dsLExpr expr) +#endif -- 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 @@ -390,7 +385,7 @@ runMeta convert expr -- 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 @@ -419,9 +414,21 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where 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} @@ -470,9 +477,9 @@ reify th_name ; 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) @@ -515,7 +522,8 @@ tcLookupTh name 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) } @@ -555,9 +563,9 @@ reifyThing (AGlobal (ADataCon dc)) ; 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) } @@ -573,9 +581,10 @@ reifyTyCon tc | 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) @@ -616,7 +625,7 @@ reifyClass cls ; 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) } @@ -654,7 +663,7 @@ reifyPred p@(IParam _ _) = noTH SLIT("implicit parameters") (ppr p) ------------------------------ 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 @@ -662,7 +671,9 @@ reifyName thing -- 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