[project @ 2004-08-16 09:53:47 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 d95ca8c..84b7216 100644 (file)
--- a/ghc/compiler/deSugar/Desugar.lhs
+++ b/ghc/compiler/deSugar/Desugar.lhs
@@ -33,17 +33,19 @@ import RdrName              ( GlobalRdrEnv )
 import NameSet
 import VarEnv
 import VarSet
-import Bag             ( isEmptyBag, mapBag, emptyBag, bagToList )
+import Bag             ( Bag, isEmptyBag, mapBag, emptyBag, bagToList )
 import CoreLint                ( showPass, endPass )
 import CoreFVs         ( ruleRhsFreeVars )
+import Packages                ( thPackage )
 import ErrUtils                ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings, 
                          mkWarnMsg, errorsFound, WarnMsg )
+import ListSetOps      ( insertList )
 import Outputable
-import qualified Pretty
 import UniqSupply      ( mkSplitUniqSupply )
 import SrcLoc          ( Located(..), SrcSpan, unLoc )
 import DATA_IOREF      ( readIORef )
 import FastString
+import Data.List       ( sort )
 \end{code}
 
 %************************************************************************
@@ -53,7 +55,7 @@ import FastString
 %************************************************************************
 
 \begin{code}
-deSugar :: HscEnv -> TcGblEnv -> IO (Maybe ModGuts)
+deSugar :: HscEnv -> TcGblEnv -> IO (Bag WarnMsg, Maybe ModGuts)
 -- Can modify PCS by faulting in more declarations
 
 deSugar hsc_env 
@@ -63,6 +65,7 @@ deSugar hsc_env
                            tcg_exports   = exports,
                            tcg_dus       = dus, 
                            tcg_inst_uses = dfun_uses_var,
+                           tcg_th_used   = th_var,
                            tcg_rdr_env   = rdr_env,
                            tcg_fix_env   = fix_env,
                            tcg_deprecs   = deprecs,
@@ -70,21 +73,16 @@ deSugar hsc_env
   = do { showPass dflags "Desugar"
 
        -- Do desugaring
-       ; let { is_boot = imp_dep_mods imports }
-       ; (results, warnings) <- initDs hsc_env mod type_env is_boot $
+       ; (results, warnings) <- initDs hsc_env mod type_env $
                                 dsProgram ghci_mode tcg_env
 
        ; let { (ds_binds, ds_rules, ds_fords) = results
              ; warns    = mapBag mk_warn warnings
-             ; warn_doc = pprBagOfWarnings warns }
-
-       -- Display any warnings
-        ; doIfSet (not (isEmptyBag warnings))
-                 (printErrs warn_doc)
+             }
 
        -- If warnings are considered errors, leave.
        ; if errorsFound dflags (warns, emptyBag)
-          then return Nothing
+          then return (warns, Nothing)
           else do
 
        -- Lint result if necessary
@@ -97,16 +95,23 @@ deSugar hsc_env
        ; dfun_uses <- readIORef dfun_uses_var          -- What dfuns are used
        ; let used_names = allUses dus `unionNameSets` dfun_uses
        ; usages <- mkUsageInfo hsc_env imports used_names
+
+       ; th_used <- readIORef th_var
        ; let 
+            pkgs | th_used   = insertList thPackage (imp_dep_pkgs imports)
+                 | otherwise = imp_dep_pkgs imports
+
             deps = Deps { dep_mods = moduleEnvElts (imp_dep_mods imports), 
-                          dep_pkgs = imp_dep_pkgs imports,
-                          dep_orphs = imp_orphs imports }
+                          dep_pkgs  = sort pkgs,       
+                          dep_orphs = sort (imp_orphs imports) }
+               -- sort to get into canonical order
+
             mod_guts = ModGuts {       
                mg_module   = mod,
                mg_exports  = exports,
                mg_deps     = deps,
                mg_usages   = usages,
-               mg_dir_imps = [m | (m,_) <- moduleEnvElts (imp_mods imports)],
+               mg_dir_imps = [m | (m,_,_) <- moduleEnvElts (imp_mods imports)],
                mg_rdr_env  = rdr_env,
                mg_fix_env  = fix_env,
                mg_deprecs  = deprecs,
@@ -116,7 +121,7 @@ deSugar hsc_env
                mg_binds    = ds_binds,
                mg_foreign  = ds_fords }
        
-        ; return (Just mod_guts)
+        ; return (warns, Just mod_guts)
        }}
 
   where
@@ -139,9 +144,7 @@ deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
        ; us <- mkSplitUniqSupply 'd'
 
        -- Do desugaring
-       ; let { is_boot = emptyModuleEnv }      -- Assume no hi-boot files when
-                                               -- doing stuff from the command line
-       ; (core_expr, ds_warns) <- initDs hsc_env this_mod type_env is_boot $
+       ; (core_expr, ds_warns) <- initDs hsc_env this_mod type_env $
                                   dsLExpr tc_expr
 
        -- Display any warnings 
@@ -234,9 +237,7 @@ addExportFlags ghci_mode exports keep_alive bndrs prs rules
        -- introduced by the type checker.
     is_exported :: Name -> Bool
     is_exported | ghci_mode == Interactive = isExternalName
-               | otherwise                = (`elemNameSet` export_fvs)
-
-    export_fvs = availsToNameSet exports
+               | otherwise                = (`elemNameSet` exports)
 
 ppr_ds_rules [] = empty
 ppr_ds_rules rules
@@ -261,7 +262,7 @@ dsRule in_scope (L loc (HsRule name act vars lhs rhs))
     returnDs (fn, Rule name act tpl_vars args core_rhs)
   where
     tpl_vars = [var | RuleBndr (L _ var) <- vars]
-    all_vars = mkInScopeSet (in_scope `unionVarSet` mkVarSet tpl_vars)
+    all_vars = mkInScopeSet (extendVarSetList in_scope tpl_vars)
 
 ds_lhs all_vars lhs
   = let