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
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}
= 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))
(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,
-- 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
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)
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 ->