[project @ 2002-11-21 17:54:17 by simonpj]

[ghc-hetmet.git] / ghc / compiler / deSugar / Desugar.lhs

diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs
index 7100acb..c5e1814 100644 (file)
--- a/ghc/compiler/deSugar/Desugar.lhs
+++ b/ghc/compiler/deSugar/Desugar.lhs
@@ -10,12 +10,12 @@ module Desugar ( deSugar, deSugarExpr ) where
 
 import CmdLineOpts     ( DynFlag(..), dopt, opt_SccProfilingOn )
 import HscTypes                ( ModGuts(..), ModGuts, HscEnv(..), ExternalPackageState(..), 
-                         PersistentCompilerState(..), 
-                         lookupType )
+                         PersistentCompilerState(..), Dependencies(..), TypeEnv, GlobalRdrEnv,
+                         lookupType, unQualInScope )
 import HsSyn           ( MonoBinds, RuleDecl(..), RuleBndr(..), 
                          HsExpr(..), HsBinds(..), MonoBinds(..) )
 import TcHsSyn         ( TypecheckedRuleDecl, TypecheckedHsExpr )
-import TcRnTypes       ( TcGblEnv(..), ImportAvails(imp_mods) )
+import TcRnTypes       ( TcGblEnv(..), ImportAvails(..) )
 import MkIface         ( mkUsageInfo )
 import Id              ( Id )
 import CoreSyn
@@ -32,11 +32,14 @@ import Id           ( Id )
 import NameEnv         ( lookupNameEnv )
 import VarEnv
 import VarSet
-import Bag             ( isEmptyBag )
+import Bag             ( isEmptyBag, mapBag )
 import CoreLint                ( showPass, endPass )
 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 )
 \end{code}
@@ -73,7 +76,7 @@ deSugar hsc_env pcs
                = initDs dflags us lookup mod
                         (dsProgram binds rules fords)
        
-             warn_doc = pprBagOfWarnings (mapBag mk_warn ds_warns))
+             warn_doc = pprBagOfWarnings (mapBag mk_warn ds_warns)
 
        -- Display any warnings
         ; doIfSet (not (isEmptyBag ds_warns))
@@ -87,9 +90,13 @@ deSugar hsc_env pcs
                  (printDump (ppr_ds_rules ds_rules))
 
        ; let 
+            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,
+               mg_deps     = deps,
                mg_usages   = mkUsageInfo hsc_env eps imports usages,
                mg_dir_imps = [m | (m,_) <- moduleEnvElts (imp_mods imports)],
                mg_rdr_env  = rdr_env,
@@ -110,7 +117,8 @@ deSugar hsc_env pcs
 
        -- Desugarer warnings are SDocs; here we
        -- add the info about whether or not to print unqualified
-    mk_warn (loc,sdoc) = (loc, addShortWarnLocLine loc print_unqual sdoc)
+    mk_warn :: (SrcLoc,SDoc) -> (SrcLoc, Pretty.Doc)
+    mk_warn (loc, sdoc) = addShortWarnLocLine loc print_unqual sdoc
 
        -- The lookup function passed to initDs is used for well-known Ids, 
        -- such as fold, build, cons etc, so the chances are
@@ -129,19 +137,20 @@ 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)
 
        -- Display any warnings
         ; doIfSet (not (isEmptyBag ds_warns))
-                 (printErrs (pprBagOfWarnings ds_warns))
+                 (printErrs warn_doc)
 
        -- Dump output
        ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr core_expr)
@@ -152,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 ->