X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FHscTypes.lhs;h=045c17fdb9138a214c75ae045a7a7e299fa79165;hb=2db3c4308e8d1ba14b502b9ccb9bee3fd3bd145e;hp=ed882397d7e4c31ceb9ad4fa74e6a7293606903f;hpb=92cdc09e48d3410182581f5bd687d1ee7cbe476b;p=ghc-hetmet.git

diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs
index ed88239..045c17f 100644
--- a/ghc/compiler/main/HscTypes.lhs
+++ b/ghc/compiler/main/HscTypes.lhs
@@ -13,7 +13,7 @@ module HscTypes (
 	HomeSymbolTable, emptySymbolTable,
 	PackageTypeEnv,
 	HomeIfaceTable, PackageIfaceTable, emptyIfaceTable,
-	lookupIface, lookupIfaceByModName,
+	lookupIface, lookupIfaceByModName, moduleNameToModule,
 	emptyModIface,
 
 	InteractiveContext(..),
@@ -21,6 +21,7 @@ module HscTypes (
 	IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
 
 	VersionInfo(..), initialVersionInfo, lookupVersion,
+	FixityEnv, lookupFixity, collectFixities,
 
 	TyThing(..), isTyClThing, implicitTyThingIds,
 
@@ -34,6 +35,7 @@ module HscTypes (
 	NameSupply(..), OrigNameCache, OrigIParamCache,
 	Avails, AvailEnv, emptyAvailEnv,
 	GenAvailInfo(..), AvailInfo, RdrAvailInfo, 
+	ExportItem, RdrExportItem,
 	PersistentCompilerState(..),
 
 	Deprecations(..), lookupDeprec,
@@ -53,38 +55,37 @@ module HscTypes (
 
 #include "HsVersions.h"
 
-import RdrName		( RdrName, RdrNameEnv, addListToRdrEnv, emptyRdrEnv, 
+import RdrName		( RdrName, RdrNameEnv, addListToRdrEnv, 
 			  mkRdrUnqual, rdrEnvToList )
 import Name		( Name, NamedThing, getName, nameOccName, nameModule, nameSrcLoc )
 import NameEnv
 import OccName		( OccName )
-import Module		( Module, ModuleName, ModuleEnv,
-			  lookupModuleEnv, lookupModuleEnvByName, 
-			  emptyModuleEnv, moduleUserString
-			)
+import Module
 import InstEnv		( InstEnv, ClsInstEnv, DFunId )
 import Rules		( RuleBase )
 import CoreSyn		( CoreBind )
 import Id		( Id )
 import Class		( Class, classSelIds )
-import TyCon		( TyCon, isNewTyCon, tyConGenIds, tyConSelIds, tyConDataConsIfAvailable )
-import DataCon		( dataConId, dataConWrapId )
+import TyCon		( TyCon, isNewTyCon, tyConGenIds, tyConSelIds, tyConDataCons_maybe )
+import DataCon		( dataConWorkId, dataConWrapId )
 
-import BasicTypes	( Version, initialVersion, Fixity, IPName )
+import BasicTypes	( Version, initialVersion, Fixity, defaultFixity, IPName )
 
-import HsSyn		( DeprecTxt, tyClDeclName, ifaceRuleDeclName )
+import HsSyn		( DeprecTxt, TyClDecl, tyClDeclName, ifaceRuleDeclName,
+			  tyClDeclNames )
 import RdrHsSyn		( RdrNameInstDecl, RdrNameRuleDecl, RdrNameTyClDecl )
 import RnHsSyn		( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl )
 
 import CoreSyn		( IdCoreRule )
 
-import FiniteMap	( FiniteMap )
+import FiniteMap
 import Bag		( Bag )
-import Maybes		( seqMaybe, orElse )
+import Maybes		( seqMaybe, orElse, expectJust )
 import Outputable
 import SrcLoc		( SrcLoc, isGoodSrcLoc )
-import Util		( thenCmp, sortLt, unJust )
+import Util		( thenCmp, sortLt )
 import UniqSupply	( UniqSupply )
+import Maybe		( fromJust )
 \end{code}
 
 %************************************************************************
@@ -123,9 +124,9 @@ instance Outputable ModuleLocation where
 showModMsg :: Bool -> Module -> ModuleLocation -> String
 showModMsg use_object mod location =
     mod_str ++ replicate (max 0 (16 - length mod_str)) ' '
-    ++" ( " ++ unJust "showModMsg" (ml_hs_file location) ++ ", "
+    ++" ( " ++ expectJust "showModMsg" (ml_hs_file location) ++ ", "
     ++ (if use_object
-	  then unJust "showModMsg" (ml_obj_file location)
+	  then expectJust "showModMsg" (ml_obj_file location)
 	  else "interpreted")
     ++ " )"
  where mod_str = moduleUserString mod
@@ -158,7 +159,8 @@ the declarations into a single indexed map in the @PersistentRenamerState@.
 \begin{code}
 data ModIface 
    = ModIface {
-        mi_module   :: !Module,		    -- Complete with package info
+        mi_module   :: !Module,
+	mi_package  :: !PackageName,	    -- Which package the module comes from
         mi_version  :: !VersionInfo,	    -- Module version number
 
         mi_orphan   :: WhetherHasOrphans,   -- Whether this module has orphans
@@ -166,12 +168,13 @@ data ModIface
 
 	mi_boot	    :: !IsBootInterface,    -- read from an hi-boot file?
 
-        mi_usages   :: ![ImportVersion Name],	
+        mi_usages   :: [ImportVersion Name],	
 		-- Usages; kept sorted so that it's easy to decide
 		-- whether to write a new iface file (changing usages
 		-- doesn't affect the version of this module)
+		-- NOT STRICT!  we read this field lazilly from the interface file
 
-        mi_exports  :: ![(ModuleName,Avails)],
+        mi_exports  :: ![ExportItem],
 		-- What it exports Kept sorted by (mod,occ), to make
 		-- version comparisons easier
 
@@ -179,8 +182,9 @@ data ModIface
 		-- Its top level environment or Nothing if we read this
 		-- interface from a file.
 
-        mi_fixities :: !(NameEnv Fixity),   -- Fixities
-	mi_deprecs  :: !Deprecations,	    -- Deprecations
+        mi_fixities :: !FixityEnv,	    -- Fixities
+	mi_deprecs  :: Deprecations,	    -- Deprecations
+		-- NOT STRICT!  we read this field lazilly from the interface file
 
 	mi_decls    :: IfaceDecls	    -- The RnDecls form of ModDetails
 		-- NOT STRICT!  we fill this field with _|_ sometimes
@@ -249,6 +253,7 @@ data ModDetails
 emptyModIface :: Module -> ModIface
 emptyModIface mod
   = ModIface { mi_module   = mod,
+	       mi_package  = preludePackage, -- XXX fully bogus
 	       mi_version  = initialVersionInfo,
 	       mi_usages   = [],
 	       mi_orphan   = False,
@@ -293,6 +298,14 @@ lookupIfaceByModName :: HomeIfaceTable -> PackageIfaceTable -> ModuleName -> May
 -- We often have two IfaceTables, and want to do a lookup
 lookupIfaceByModName hit pit mod
   = lookupModuleEnvByName hit mod `seqMaybe` lookupModuleEnvByName pit mod
+
+-- Use instead of Finder.findModule if possible: this way doesn't
+-- require filesystem operations, and it is guaranteed not to fail
+-- when the IfaceTables are properly populated (i.e. after the renamer).
+moduleNameToModule :: HomeIfaceTable -> PackageIfaceTable -> ModuleName
+   -> Module
+moduleNameToModule hit pit mod 
+   = mi_module (fromJust (lookupIfaceByModName hit pit mod))
 \end{code}
 
 
@@ -371,14 +384,14 @@ implicitTyThingIds things
     go (AClass cl) = classSelIds cl
     go (ATyCon tc) = tyConGenIds tc ++
 		     tyConSelIds tc ++
-		     [ n | dc <- tyConDataConsIfAvailable tc, 
+		     [ n | dc <- tyConDataCons_maybe tc `orElse` [],
 			   n  <- implicitConIds tc dc]
 		-- Synonyms return empty list of constructors and selectors
 
     implicitConIds tc dc	-- Newtypes have a constructor wrapper,
 				-- but no worker
 	| isNewTyCon tc = [dataConWrapId dc]
-	| otherwise     = [dataConId dc, dataConWrapId dc]
+	| otherwise     = [dataConWorkId dc, dataConWrapId dc]
 \end{code}
 
 
@@ -477,11 +490,14 @@ data GenAvailInfo name	= Avail name	 -- An ordinary identifier
 			deriving( Eq )
 			-- Equality used when deciding if the interface has changed
 
+type RdrExportItem = (ModuleName, [RdrAvailInfo])
+type ExportItem    = (ModuleName, [AvailInfo])
+
 type AvailEnv = NameEnv AvailInfo	-- Maps a Name to the AvailInfo that contains it
 
 emptyAvailEnv :: AvailEnv
 emptyAvailEnv = emptyNameEnv
-				
+
 instance Outputable n => Outputable (GenAvailInfo n) where
    ppr = pprAvail
 
@@ -493,10 +509,24 @@ pprAvail (AvailTC n ns) = ppr n <> case {- filter (/= n) -} ns of
 pprAvail (Avail n) = ppr n
 \end{code}
 
+\begin{code}
+type FixityEnv = NameEnv Fixity
+
+lookupFixity :: FixityEnv -> Name -> Fixity
+lookupFixity env n = lookupNameEnv env n `orElse` defaultFixity
+
+collectFixities :: FixityEnv -> [TyClDecl Name pat] -> [(Name,Fixity)]
+collectFixities env decls
+  = [ (n, fix) 
+    | d <- decls, (n,_) <- tyClDeclNames d,
+      Just fix <- [lookupNameEnv env n]
+    ]
+\end{code}
+
 
 %************************************************************************
 %*									*
-\subsection{ModIface}
+\subsection{WhatsImported}
 %*									*
 %************************************************************************