From: simonpj <unknown>
Date: Thu, 21 Nov 2002 15:51:44 +0000 (+0000)
Subject: [project @ 2002-11-21 15:51:43 by simonpj]
X-Git-Tag: Approx_11550_changesets_converted~1407
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=11047b5e250ae889a642429a8d39ec0991cd26da;p=ghc-hetmet.git

[project @ 2002-11-21 15:51:43 by simonpj]
-------------------------------
	Pass the current-module type envt
to HscMain.compileExpr, and thence to the desugarer
	-------------------------------

For Template Haskell it's important to have the type envt of
the current module available to hand the desugarer.

Should fix TH_spliceDecl3
---

diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs
index 5880de0..f06cd26 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(..), Dependencies(..),
+			  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 )
@@ -136,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 mod_name 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)    
 	      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))
@@ -162,9 +161,15 @@ 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 = 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 ->
diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 49f4a2f..f5e239a 100644
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -514,7 +514,9 @@ hscStmt hsc_env pcs icontext stmt
 
 		-- Then desugar, code gen, and link it
 	; hval <- compileExpr hsc_env pcs1 iNTERACTIVE 
-			      (icPrintUnqual new_ic) tc_expr
+			      (ic_rn_gbl_env new_ic) 
+			      (ic_type_env new_ic)
+			      tc_expr
 
 	; return (pcs1, Just (new_ic, bound_names, hval))
 	}}}}}
@@ -632,15 +634,15 @@ myParseIdentifier dflags str
 #ifdef GHCI
 compileExpr :: HscEnv 
 	    -> PersistentCompilerState
-	    -> Module -> PrintUnqualified
+	    -> Module -> GlobalRdrEnv -> TypeEnv
 	    -> TypecheckedHsExpr
 	    -> IO HValue
 
-compileExpr hsc_env pcs this_mod print_unqual tc_expr
+compileExpr hsc_env pcs this_mod type_env rdr_env tc_expr
   = do	{ let dflags = hsc_dflags hsc_env
 
 	 	-- Desugar it
-	; ds_expr <- deSugarExpr hsc_env pcs this_mod print_unqual tc_expr
+	; ds_expr <- deSugarExpr hsc_env pcs this_mod rdr_env type_env tc_expr
 	
 		-- Flatten it
 	; flat_expr <- flattenExpr hsc_env pcs ds_expr