X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FHscTypes.lhs;h=1800e84f301d4fd675592537f00a3ce3d55d796b;hb=dbfe93e664ee00ad854114128ffbace2a5298da4;hp=dd5e350081fda4a218a6300289594b46e928df5a;hpb=4aed87eb62c9cf8645dcb7feb32892bb0f09f5f3;p=ghc-hetmet.git

diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs
index dd5e350..1800e84 100644
--- a/ghc/compiler/main/HscTypes.lhs
+++ b/ghc/compiler/main/HscTypes.lhs
@@ -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,7 +55,7 @@ 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
@@ -64,18 +66,19 @@ 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 Outputable
@@ -169,7 +172,7 @@ data ModIface
 		-- whether to write a new iface file (changing usages
 		-- doesn't affect the version of this module)
 
-        mi_exports  :: ![(ModuleName,Avails)],
+        mi_exports  :: ![ExportItem],
 		-- What it exports Kept sorted by (mod,occ), to make
 		-- version comparisons easier
 
@@ -177,7 +180,7 @@ data ModIface
 		-- Its top level environment or Nothing if we read this
 		-- interface from a file.
 
-        mi_fixities :: !(NameEnv Fixity),   -- Fixities
+        mi_fixities :: !FixityEnv,	    -- Fixities
 	mi_deprecs  :: !Deprecations,	    -- Deprecations
 
 	mi_decls    :: IfaceDecls	    -- The RnDecls form of ModDetails
@@ -370,14 +373,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}
 
 
@@ -476,11 +479,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
 
@@ -492,6 +498,20 @@ 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}
+
 
 %************************************************************************
 %*									*