X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDesugar.lhs;h=c5e1814b2b7bb10f196617b52bd5f00a5b11fca2;hb=0df435464ff825eb66e409fb5668a53cd5362309;hp=a91859051753e4b79b1309b2a3fbf9667aa7067c;hpb=e0445ffa5a89632b542e7d7bc2ad46d944716453;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs
index a918590..c5e1814 100644
--- a/ghc/compiler/deSugar/Desugar.lhs
+++ b/ghc/compiler/deSugar/Desugar.lhs
@@ -10,7 +10,7 @@ module Desugar ( deSugar, deSugarExpr ) where
 
 import CmdLineOpts	( DynFlag(..), dopt, opt_SccProfilingOn )
 import HscTypes		( ModGuts(..), ModGuts, HscEnv(..), ExternalPackageState(..), 
-			  PersistentCompilerState(..), 
+			  PersistentCompilerState(..), Dependencies(..), TypeEnv, GlobalRdrEnv,
 	  		  lookupType, unQualInScope )
 import HsSyn		( MonoBinds, RuleDecl(..), RuleBndr(..), 
 			  HsExpr(..), HsBinds(..), MonoBinds(..) )
@@ -38,6 +38,7 @@ import ErrUtils		( doIfSet, dumpIfSet_dyn, pprBagOfWarnings, addShortWarnLocLine
 import Outputable
 import qualified Pretty
 import UniqSupply	( mkSplitUniqSupply )
+import Maybes		( orElse )
 import SrcLoc		( SrcLoc )
 import FastString
 import DATA_IOREF	( readIORef )
@@ -89,7 +90,9 @@ deSugar hsc_env pcs
 		  (printDump (ppr_ds_rules ds_rules))
 
 	; let 
-	     deps = (moduleEnvElts (dep_mods imports), dep_pkgs imports)
+	     deps = Deps { dep_mods = moduleEnvElts (imp_dep_mods imports), 
+			   dep_pkgs = imp_dep_pkgs imports,
+			   dep_orphs = imp_orphs imports }
 	     mod_guts = ModGuts {	
 		mg_module   = mod,
 		mg_exports  = exports,
@@ -134,18 +137,16 @@ deSugar hsc_env pcs
 
 deSugarExpr :: HscEnv
 	    -> PersistentCompilerState
-	    -> Module -> PrintUnqualified
+	    -> Module -> GlobalRdrEnv -> TypeEnv 
  	    -> TypecheckedHsExpr
 	    -> IO CoreExpr
-deSugarExpr hsc_env pcs mod_name unqual tc_expr
+deSugarExpr hsc_env pcs this_mod rdr_env type_env tc_expr
   = do	{ showPass dflags "Desugar"
 	; us <- mkSplitUniqSupply 'd'
 
 	-- Do desugaring
-	; let (core_expr, ds_warns) = initDs dflags us lookup mod_name (dsExpr tc_expr)    
+	; let (core_expr, ds_warns) = initDs dflags us lookup this_mod (dsExpr tc_expr)    
 	      warn_doc = pprBagOfWarnings (mapBag mk_warn ds_warns)
-	      mk_warn :: (SrcLoc,SDoc) -> (SrcLoc, Pretty.Doc)
-	      mk_warn (loc,sdoc) = addShortWarnLocLine loc unqual sdoc
 
 	-- Display any warnings
         ; doIfSet (not (isEmptyBag ds_warns))
@@ -160,9 +161,17 @@ deSugarExpr hsc_env pcs mod_name unqual tc_expr
     dflags   = hsc_dflags hsc_env
     hpt      = hsc_HPT hsc_env
     pte      = eps_PTE (pcs_EPS pcs)
-    lookup n = case lookupType hpt pte n of
-		 Just v -> v 
-		 other	-> pprPanic "Desugar: lookup:" (ppr n)
+    lookup n = pprTrace "lookup" (ppr type_env) (
+	       lookupNameEnv type_env n	`orElse`	-- Look in the type env of the
+							-- current module first
+	       lookupType hpt pte n 	`orElse`	-- Then other modules
+	       pprPanic "Desugar: lookup:" (ppr n)
+		)
+
+    mk_warn :: (SrcLoc,SDoc) -> (SrcLoc, Pretty.Doc)
+    mk_warn (loc,sdoc) = addShortWarnLocLine loc print_unqual sdoc
+
+    print_unqual = unQualInScope rdr_env
 
 dsProgram all_binds rules fo_decls
   = dsMonoBinds auto_scc all_binds []	`thenDs` \ core_prs ->