[project @ 2000-10-16 13:13:41 by sewardj]

[ghc-hetmet.git] / ghc / compiler / main / HscTypes.lhs

diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs
index 2138d48..afc710a 100644 (file)
--- a/ghc/compiler/main/HscTypes.lhs
+++ b/ghc/compiler/main/HscTypes.lhs
@@ -15,7 +15,7 @@ module HscTypes (
 
        InstEnv, 
 
-               -- Provenance
+       -- Provenance
        Provenance(..), ImportReason(..), PrintUnqualified,
         pprProvenance, hasBetterProv
 
@@ -25,7 +25,8 @@ module HscTypes (
 
 import Name            ( Name, NameEnv, NamedThing,
                          unitNameEnv, extendNameEnv, plusNameEnv, 
-                         lookupNameEnv, emptyNameEnv, getName, nameModule )
+                         lookupNameEnv, emptyNameEnv, getName, nameModule,
+                         nameSrcLoc )
 import Module          ( Module, ModuleName,
                          extendModuleEnv, lookupModuleEnv )
 import Class           ( Class )
@@ -36,7 +37,7 @@ import UniqFM                 ( UniqFM )
 import FiniteMap       ( FiniteMap, emptyFM, addToFM, lookupFM, foldFM )
 import Bag             ( Bag )
 import Id              ( Id )
-import VarEnv          ( IdEnv )
+import VarEnv          ( IdEnv, emptyVarEnv )
 import BasicTypes      ( Version, Fixity, defaultFixity )
 import TyCon           ( TyCon )
 import ErrUtils                ( ErrMsg, WarnMsg )
@@ -49,9 +50,9 @@ import CoreSyn                ( CoreRule )
 import NameSet         ( NameSet )
 import Type            ( Type )
 import VarSet          ( TyVarSet )
-import {-# SOURCE #-} 
-       TcInstUtil ( emptyInstEnv )
 import Panic           ( panic )
+import Outputable
+import SrcLoc          ( SrcLoc, isGoodSrcLoc )
 \end{code}
 
 %************************************************************************
@@ -65,29 +66,29 @@ A @ModDetails@ summarises everything we know about a compiled module.
 \begin{code}
 data ModDetails
    = ModDetails {
-       moduleId      :: Module,
-        moduleExports :: Avails,               -- What it exports
-       mdVersion     :: VersionInfo,
-        moduleEnv     :: GlobalRdrEnv,         -- Its top level environment
+       md_id       :: Module,
+        md_exports  :: Avails,         -- What it exports
+       md_version  :: VersionInfo,
+        md_globals  :: GlobalRdrEnv,   -- Its top level environment
 
-        fixityEnv     :: NameEnv Fixity,
-       deprecEnv     :: NameEnv DeprecTxt,
-        typeEnv       :: TypeEnv,
+        md_fixities :: NameEnv Fixity,
+       md_deprecs  :: NameEnv DeprecTxt,
+        md_types    :: TypeEnv,
 
-        mdInsts       :: [DFunId],     -- Dfun-ids for the instances in this module
-        mdRules       :: RuleEnv       -- Domain may include Id from other modules
+        md_insts    :: [DFunId],       -- Dfun-ids for the instances in this module
+        md_rules    :: RuleEnv         -- Domain may include Id from other modules
      }
 
 emptyModDetails :: Module -> ModDetails
 emptyModDetails mod
-  = ModDetails { moduleId      = mod,
-                moduleExports = [],
-                moduleEnv     = emptyRdrEnv,
-                fixityEnv     = emptyNameEnv,
-                deprecEnv     = emptyNameEnv,
-                typeEnv       = emptyNameEnv,
-                mdInsts       = [],
-                mdRules       = emptyRuleEnv
+  = ModDetails { md_id       = mod,
+                md_exports  = [],
+                md_globals  = emptyRdrEnv,
+                md_fixities = emptyNameEnv,
+                md_deprecs  = emptyNameEnv,
+                md_types    = emptyNameEnv,
+                md_insts    = [],
+                md_rules    = emptyRuleEnv
     }          
 \end{code}
 
@@ -108,7 +109,7 @@ lookupFixityEnv :: SymbolTable -> Name -> Maybe Fixity
 lookupFixityEnv tbl name
   = case lookupModuleEnv tbl (nameModule name) of
        Nothing      -> Nothing
-       Just details -> lookupNameEnv (fixityEnv details) name
+       Just details -> lookupNameEnv (md_fixities details) name
 \end{code}
 
 
@@ -136,7 +137,7 @@ instance NamedThing TyThing where
 lookupTypeEnv :: SymbolTable -> Name -> Maybe TyThing
 lookupTypeEnv tbl name
   = case lookupModuleEnv tbl (nameModule name) of
-       Just details -> lookupNameEnv (typeEnv details) name
+       Just details -> lookupNameEnv (md_types details) name
        Nothing      -> Nothing
 
 
@@ -163,8 +164,8 @@ extendTypeEnv tbl things
        where
          new_details 
              = case lookupModuleEnv tbl mod of
-                  Nothing      -> (emptyModDetails mod) {typeEnv = type_env}
-                  Just details -> details {typeEnv = typeEnv details 
+                  Nothing      -> (emptyModDetails mod) {md_types = type_env}
+                  Just details -> details {md_types = md_types details 
                                                      `plusNameEnv` type_env}
 \end{code}
 
@@ -434,6 +435,16 @@ data Provenance
        ImportReason
        PrintUnqualified
 
+{-
+Moved here from Name.
+pp_prov (LocalDef _ Exported)          = char 'x'
+pp_prov (LocalDef _ NotExported)       = char 'l'
+pp_prov (NonLocalDef ImplicitImport _) = char 'j'
+pp_prov (NonLocalDef (UserImport _ _ True ) _) = char 'I'      -- Imported by name
+pp_prov (NonLocalDef (UserImport _ _ False) _) = char 'i'      -- Imported by ..
+pp_prov SystemProv                    = char 's'
+-}
+
 data ImportReason
   = UserImport Module SrcLoc Bool      -- Imported from module M on line L
                                        -- Note the M may well not be the defining module
@@ -465,7 +476,7 @@ hasBetterProv (NonLocalDef (UserImport _ _ True) _) _                                  = True
 hasBetterProv (NonLocalDef (UserImport _ _ _   ) _) (NonLocalDef ImplicitImport _) = True
 hasBetterProv _                                            _                              = False
 
-pprNameProvenance :: Name -> Provenance -> SDoc
+pprProvenance :: Name -> Provenance -> SDoc
 pprProvenance name LocalDef           = ptext SLIT("defined at") <+> ppr (nameSrcLoc name)
 pprProvenance name (NonLocalDef why _) = sep [ppr_reason why, 
                                              nest 2 (parens (ppr_defn (nameSrcLoc name)))]