[project @ 2005-01-27 10:44:00 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 e7ae7ee..be26463 100644 (file)
--- a/ghc/compiler/deSugar/Desugar.lhs
+++ b/ghc/compiler/deSugar/Desugar.lhs
@@ -8,40 +8,41 @@ module Desugar ( deSugar, deSugarExpr ) where
 
 #include "HsVersions.h"
 
-import CmdLineOpts     ( DynFlag(..), dopt, opt_SccProfilingOn )
+import CmdLineOpts     ( DynFlag(..), DynFlags(..), dopt, opt_SccProfilingOn )
+import DriverPhases    ( isHsBoot )
 import HscTypes                ( ModGuts(..), ModGuts, HscEnv(..), GhciMode(..),
-                         Dependencies(..), TypeEnv, IsBootInterface, unQualInScope )
+                         Dependencies(..), TypeEnv, IsBootInterface )
 import HsSyn           ( RuleDecl(..), RuleBndr(..), HsExpr(..), LHsExpr,
                          HsBindGroup(..), LRuleDecl, HsBind(..) )
 import TcRnTypes       ( TcGblEnv(..), ImportAvails(..) )
 import MkIface         ( mkUsageInfo )
-import Id              ( Id, setIdLocalExported, idName, idIsFrom, isLocalId )
+import Id              ( Id, setIdExported, idName, idIsFrom )
 import Name            ( Name, isExternalName )
 import CoreSyn
 import PprCore         ( pprIdRules, pprCoreExpr )
-import Subst           ( SubstResult(..), substExpr, mkSubst, extendIdSubstList )
+import CoreSubst       ( substExpr, mkSubst )
 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, ModuleName, moduleEnvElts, delModuleEnv, moduleNameFS )
+import Module          ( Module, moduleEnvElts, delModuleEnv, moduleFS )
 import Id              ( Id )
 import RdrName         ( GlobalRdrEnv )
 import NameSet
 import VarEnv
 import VarSet
-import Bag             ( Bag, isEmptyBag, mapBag, emptyBag, bagToList )
+import Bag             ( Bag, isEmptyBag, emptyBag, bagToList )
 import CoreLint                ( showPass, endPass )
 import CoreFVs         ( ruleRhsFreeVars )
-import Packages                ( thPackage )
+import Packages                ( PackageState(thPackageId), PackageIdH(..) )
 import ErrUtils                ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings, 
-                         mkWarnMsg, errorsFound, WarnMsg )
+                         errorsFound, WarnMsg )
 import ListSetOps      ( insertList )
 import Outputable
 import UniqSupply      ( mkSplitUniqSupply )
-import SrcLoc          ( Located(..), SrcSpan, unLoc )
+import SrcLoc          ( Located(..), unLoc )
 import DATA_IOREF      ( readIORef )
 import FastString
 import Util            ( sortLe )
@@ -59,6 +60,7 @@ deSugar :: HscEnv -> TcGblEnv -> IO (Bag WarnMsg, Maybe ModGuts)
 
 deSugar hsc_env 
         tcg_env@(TcGblEnv { tcg_mod       = mod,
+                           tcg_src       = hsc_src,
                            tcg_type_env  = type_env,
                            tcg_imports   = imports,
                            tcg_exports   = exports,
@@ -113,8 +115,11 @@ deSugar hsc_env
        ; dfun_uses <- readIORef dfun_uses_var          -- What dfuns are used
        ; th_used   <- readIORef th_var                 -- Whether TH is used
        ; let used_names = allUses dus `unionNameSets` dfun_uses
-             pkgs | th_used   = insertList thPackage (imp_dep_pkgs imports)
-                  | otherwise = imp_dep_pkgs imports
+             thPackage = thPackageId (pkgState dflags)
+             pkgs | ExtPackage th_id <- thPackage, th_used
+                  = insertList th_id  (imp_dep_pkgs imports)
+                  | otherwise
+                  = imp_dep_pkgs imports
 
              dep_mods = moduleEnvElts (delModuleEnv (imp_dep_mods imports) mod)
                -- M.hi-boot can be in the imp_dep_mods, but we must remove
@@ -129,11 +134,11 @@ deSugar hsc_env
        ; usages <- mkUsageInfo hsc_env dir_imp_mods dep_mods used_names
 
        ; let 
-               -- ModuleNames don't compare lexicographically usually, 
+               -- Modules 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_mod :: Module -> Module -> Bool  
+            le_mod m1 m2 = moduleFS m1 <= moduleFS m2
+            le_dep_mod :: (Module, IsBootInterface) -> (Module, IsBootInterface) -> Bool        
             le_dep_mod (m1,_) (m2,_) = m1 `le_mod` m2
 
             deps = Deps { dep_mods  = sortLe le_dep_mod dep_mods,
@@ -143,6 +148,7 @@ deSugar hsc_env
 
             mod_guts = ModGuts {       
                mg_module   = mod,
+               mg_boot     = isHsBoot hsc_src,
                mg_exports  = exports,
                mg_deps     = deps,
                mg_usages   = usages,
@@ -211,11 +217,8 @@ addExportFlags ghci_mode exports keep_alive prs rules
   = [(add_export bndr, rhs) | (bndr,rhs) <- prs]
   where
     add_export bndr
-       | isLocalId bndr && dont_discard bndr  = setIdLocalExported bndr
-               -- The isLocalId check is to avoid fiddling with
-               -- locally-defined Ids like data cons and class ops
-               -- which are "born" as GlobalIds
-       | otherwise                            = bndr
+       | dont_discard bndr = setIdExported bndr
+       | otherwise         = bndr
 
     orph_rhs_fvs = unionVarSets [ ruleRhsFreeVars rule
                                | IdCoreRule _ is_orphan_rule rule <- rules, 
@@ -282,10 +285,11 @@ ds_lhs all_vars lhs
        -- Substitute the dict bindings eagerly,
        -- and take the body apart into a (f args) form
     let
-       subst = extendIdSubstList (mkSubst all_vars) pairs
-       pairs = [(id, ContEx subst rhs) | (id,rhs) <- dict_binds']
+       subst = mkSubst all_vars emptyVarEnv (mkVarEnv id_pairs)
+       id_pairs = [(id, substExpr subst rhs) | (id,rhs) <- dict_binds']
                        -- Note recursion here... substitution won't terminate
                        -- if there is genuine recursion... which there isn't
+
        body'' = substExpr subst body'
     in