[project @ 2004-10-01 13:42:04 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 599c759..02f60ed 100644 (file)
--- a/ghc/compiler/deSugar/Desugar.lhs
+++ b/ghc/compiler/deSugar/Desugar.lhs
@@ -10,8 +10,7 @@ module Desugar ( deSugar, deSugarExpr ) where
 
 import CmdLineOpts     ( DynFlag(..), dopt, opt_SccProfilingOn )
 import HscTypes                ( ModGuts(..), ModGuts, HscEnv(..), GhciMode(..),
-                         Dependencies(..), TypeEnv, 
-                         unQualInScope, availsToNameSet )
+                         Dependencies(..), TypeEnv, IsBootInterface, unQualInScope )
 import HsSyn           ( RuleDecl(..), RuleBndr(..), HsExpr(..), LHsExpr,
                          HsBindGroup(..), LRuleDecl, HsBind(..) )
 import TcRnTypes       ( TcGblEnv(..), ImportAvails(..) )
@@ -20,14 +19,14 @@ import Id           ( Id, setIdLocalExported, idName )
 import Name            ( Name, isExternalName )
 import CoreSyn
 import PprCore         ( pprIdRules, pprCoreExpr )
-import Subst           ( substExpr, mkSubst, mkInScopeSet )
+import Subst           ( SubstResult(..), substExpr, mkSubst, extendIdSubstList )
 import DsMonad
 import DsExpr          ( dsLExpr )
 import DsBinds         ( dsHsBinds, AutoScc(..) )
 import DsForeign       ( dsForeigns )
 import DsExpr          ()      -- Forces DsExpr to be compiled; DsBinds only
                                -- depends on DsExpr.hi-boot.
-import Module          ( Module, moduleEnvElts, emptyModuleEnv )
+import Module          ( Module, ModuleName, moduleEnvElts, delModuleEnv, moduleNameFS )
 import Id              ( Id )
 import RdrName         ( GlobalRdrEnv )
 import NameSet
@@ -36,13 +35,16 @@ import VarSet
 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 UniqSupply      ( mkSplitUniqSupply )
 import SrcLoc          ( Located(..), SrcSpan, unLoc )
 import DATA_IOREF      ( readIORef )
 import FastString
+import Util            ( sortLe )
 \end{code}
 
 %************************************************************************
@@ -62,6 +64,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,
@@ -69,8 +72,7 @@ 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
@@ -92,16 +94,34 @@ 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 
-            deps = Deps { dep_mods = moduleEnvElts (imp_dep_mods imports), 
-                          dep_pkgs = imp_dep_pkgs imports,
-                          dep_orphs = imp_orphs imports }
+            pkgs | th_used   = insertList thPackage (imp_dep_pkgs imports)
+                 | otherwise = imp_dep_pkgs imports
+
+            mods = moduleEnvElts (delModuleEnv (imp_dep_mods imports) mod)
+               -- M.hi-boot can be in the imp_dep_mods, but we must remove
+               -- it before recording the modules on which this one depends!
+
+               -- ModuleNames don't compare lexicographically usually, 
+               -- but we want them to do so here.
+            le_mod :: ModuleName -> ModuleName -> Bool  
+            le_mod m1 m2 = moduleNameFS m1 <= moduleNameFS m2
+            le_dep_mod :: (ModuleName, IsBootInterface) -> (ModuleName, IsBootInterface) -> Bool        
+            le_dep_mod (m1,_) (m2,_) = m1 `le_mod` m2
+
+            deps = Deps { dep_mods  = sortLe le_dep_mod mods,
+                          dep_pkgs  = sortLe (<=)   pkgs,      
+                          dep_orphs = sortLe le_mod (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,
@@ -134,9 +154,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 
@@ -269,12 +287,10 @@ ds_lhs all_vars lhs
        -- Substitute the dict bindings eagerly,
        -- and take the body apart into a (f args) form
     let
-       subst_env = mkSubstEnv [id                   | (id,rhs) <- dict_binds']
-                              [ContEx subst_env rhs | (id,rhs) <- dict_binds']
+       subst = extendIdSubstList (mkSubst all_vars) pairs
+       pairs = [(id, ContEx subst rhs) | (id,rhs) <- dict_binds']
                        -- Note recursion here... substitution won't terminate
                        -- if there is genuine recursion... which there isn't
-
-       subst = mkSubst all_vars subst_env
        body'' = substExpr subst body'
     in