X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FHscTypes.lhs;h=1b119c492d96a42c8ec7344533a9edb215994c8a;hb=fd99cf4f7c390e4b1abc9a839a6f023d3b6c4757;hp=02da2230f7b7299c2f3348069973fa5f871ab9e5;hpb=b55a5d5d522bb70a5a3e309fef4bb62eca8a4e6b;p=ghc-hetmet.git

diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs
index 02da223..1b119c4 100644
--- a/ghc/compiler/main/HscTypes.lhs
+++ b/ghc/compiler/main/HscTypes.lhs
@@ -5,7 +5,7 @@
 
 \begin{code}
 module HscTypes ( 
-	Finder, ModuleLocation(..),
+	ModuleLocation(..),
 
 	ModDetails(..),	ModIface(..), GlobalSymbolTable, 
 	HomeSymbolTable, PackageSymbolTable,
@@ -16,9 +16,10 @@ module HscTypes (
 
 	VersionInfo(..), initialVersionInfo,
 
-	TyThing(..), groupTyThings,
+	TyThing(..), groupTyThings, isTyClThing,
 
 	TypeEnv, extendTypeEnv, lookupTypeEnv, 
+	typeEnvClasses, typeEnvTyCons,
 
 	WhetherHasOrphans, ImportVersion, WhatsImported(..),
 	PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap,
@@ -46,14 +47,14 @@ import RdrName		( RdrNameEnv, emptyRdrEnv )
 import Name		( Name, NameEnv, NamedThing,
 			  emptyNameEnv, unitNameEnv, extendNameEnv, plusNameEnv, 
 			  lookupNameEnv, emptyNameEnv, getName, nameModule,
-			  nameSrcLoc )
+			  nameSrcLoc, nameEnvElts )
 import NameSet		( NameSet )
 import OccName		( OccName )
 import Module		( Module, ModuleName, ModuleEnv,
-			  lookupModuleEnv, lookupModuleEnvByName
+			  extendModuleEnv, lookupModuleEnv, lookupModuleEnvByName
 			)
+import Rules		( RuleBase )
 import VarSet		( TyVarSet )
-import VarEnv		( emptyVarEnv )
 import Id		( Id )
 import Class		( Class )
 import TyCon		( TyCon )
@@ -64,7 +65,7 @@ import HsSyn		( DeprecTxt )
 import RdrHsSyn		( RdrNameHsDecl, RdrNameTyClDecl )
 import RnHsSyn		( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl )
 
-import CoreSyn		( CoreRule )
+import CoreSyn		( CoreRule, IdCoreRule )
 import Type		( Type )
 
 import FiniteMap	( FiniteMap, emptyFM, addToFM, lookupFM, foldFM )
@@ -79,13 +80,11 @@ import UniqSupply	( UniqSupply )
 
 %************************************************************************
 %*									*
-\subsection{The Finder type}
+\subsection{Module locations}
 %*									*
 %************************************************************************
 
 \begin{code}
-type Finder = ModuleName -> IO (Maybe (Module, ModuleLocation))
-
 data ModuleLocation
    = ModuleLocation {
 	hs_file  :: FilePath,
@@ -126,7 +125,7 @@ data ModIface
 						-- (changing usages doesn't affect the version of
 						--  this module)
 
-        mi_exports  :: Avails,			-- What it exports
+        mi_exports  :: [(ModuleName,Avails)],	-- What it exports
 						-- Kept sorted by (mod,occ),
 						-- to make version comparisons easier
 
@@ -149,7 +148,7 @@ data ModDetails
 	-- The next three fields are created by the typechecker
         md_types    :: TypeEnv,
         md_insts    :: [DFunId],	-- Dfun-ids for the instances in this module
-        md_rules    :: RuleBase		-- Domain may include Ids from other modules
+        md_rules    :: [IdCoreRule]	-- Domain may include Ids from other modules
      }
 \end{code}
 
@@ -158,7 +157,7 @@ emptyModDetails :: ModDetails
 emptyModDetails
   = ModDetails { md_types = emptyTypeEnv,
                  md_insts = [],
-                 md_rules = emptyRuleBase
+                 md_rules = []
     }
 
 emptyModIface :: Module -> ModIface
@@ -215,10 +214,19 @@ data TyThing = AnId   Id
 	     | ATyCon TyCon
 	     | AClass Class
 
+isTyClThing :: TyThing -> Bool
+isTyClThing (ATyCon _) = True
+isTyClThing (AClass _) = True
+isTyClThing (AnId   _) = False
+
 instance NamedThing TyThing where
   getName (AnId id)   = getName id
   getName (ATyCon tc) = getName tc
   getName (AClass cl) = getName cl
+
+typeEnvClasses env = [cl | AClass cl <- nameEnvElts env]
+typeEnvTyCons  env = [tc | ATyCon tc <- nameEnvElts env] 
+
 \end{code}
 
 
@@ -249,7 +257,7 @@ extendTypeEnv tbl things
   = foldFM add tbl things
   where
     add mod type_env tbl
-	= panic "extendTypeEnv" --extendModuleEnv mod new_details
+	= extendModuleEnv tbl mod new_details
 	where
 	  new_details 
              = case lookupModuleEnv tbl mod of
@@ -288,16 +296,19 @@ initialVersionInfo = VersionInfo { vers_module  = initialVersion,
 				   vers_decls   = emptyNameEnv }
 
 data Deprecations = NoDeprecs
-	 	  | DeprecAll DeprecTxt			-- Whole module deprecated
-		  | DeprecSome (NameEnv DeprecTxt)	-- Some things deprecated
-							-- Just "big" names
+	 	  | DeprecAll DeprecTxt				-- Whole module deprecated
+		  | DeprecSome (NameEnv (Name,DeprecTxt))	-- Some things deprecated
+								-- Just "big" names
+		-- We keep the Name in the range, so we can print them out
 
 lookupDeprec :: ModIface -> Name -> Maybe DeprecTxt
 lookupDeprec iface name
   = case mi_deprecs iface of
 	NoDeprecs      -> Nothing
 	DeprecAll txt  -> Just txt
-	DeprecSome env -> lookupNameEnv env name
+	DeprecSome env -> case lookupNameEnv env name of
+			    Just (_, txt) -> Just txt
+			    Nothing	  -> Nothing
 
 type InstEnv    = UniqFM ClsInstEnv		-- Maps Class to instances for that class
 
@@ -386,7 +397,7 @@ data PersistentCompilerState
 	pcs_insts :: PackageInstEnv,	-- The total InstEnv accumulated from all
 					--   the non-home-package modules
 
-	pcs_rules :: PackageRuleEnv,	-- Ditto RuleEnv
+	pcs_rules :: PackageRuleBase,	-- Ditto RuleEnv
 
         pcs_PRS :: PersistentRenamerState
      }