X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=d59b0f885296c1b7bf666dcda4456c7ef7c6b2d4;hb=67ee8a93fc96a38c3f73468cb86d8421a11d2911;hp=beb72f193278b25f81b006e010c6ccf178a18739;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index beb72f1..d59b0f8 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -41,7 +41,7 @@ import NameEnv ( lookupNameEnv ) import HscTypes ( lookupType, ExternalPackageState(..), emptyModDetails ) import OccName import Var ( Id, TyVar, idType ) -import Module ( moduleString ) +import Module ( moduleName, moduleNameString, modulePackageId ) import TcRnMonad import IfaceEnv ( lookupOrig ) import Class ( Class, classExtraBigSig ) @@ -55,11 +55,13 @@ import Id ( idName, globalIdDetails ) import IdInfo ( GlobalIdDetails(..) ) import TysWiredIn ( mkListTy ) import DsMeta ( expQTyConName, typeQTyConName, decTyConName, qTyConName, nameTyConName ) +import DsExpr ( dsLExpr ) +import DsMonad ( initDsTc ) import ErrUtils ( Message ) import SrcLoc ( SrcSpan, noLoc, unLoc, getLoc ) import Outputable import Unique ( Unique, Uniquable(..), getKey, mkUniqueGrimily ) - +import PackageConfig ( packageIdString ) import BasicTypes ( StrictnessMark(..), Fixity(..), FixityDirection(..) ) import Panic ( showException ) import FastString ( LitString ) @@ -97,7 +99,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 +370,14 @@ 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 + 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 @@ -390,7 +389,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 +418,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 +481,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 +526,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 +567,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_ty = 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) } @@ -654,7 +666,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 +674,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