X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=6ac66d6ea8ae09a2cec1df33dd59037fc3efe7a2;hb=1525a5819aa3a6eae8d8b05cfe348a2384da0c84;hp=7c3aa8637ab2574ecf0726846f22f3593d6787ad;hpb=f7f06be1f47dcb3a48c4bc7ef0a2c59e49e28115;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 7c3aa86..6ac66d6 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
@@ -419,7 +418,10 @@ 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
 
 	-- For qRecover, discard error messages if 
@@ -479,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)
@@ -524,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) }
@@ -663,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
@@ -671,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