From: simonpj <unknown>
Date: Wed, 25 Oct 2000 15:57:33 +0000 (+0000)
Subject: [project @ 2000-10-25 15:57:33 by simonpj]
X-Git-Tag: Approximately_9120_patches~3507
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=bac531aaf56c7558eda70531e9565f753d21f848;p=ghc-hetmet.git

[project @ 2000-10-25 15:57:33 by simonpj]
writeIface stuff
---

diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs
index 9150218..9a97728 100644
--- a/ghc/compiler/main/HscTypes.lhs
+++ b/ghc/compiler/main/HscTypes.lhs
@@ -126,7 +126,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
 
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 128bcf7..c911132 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -5,7 +5,7 @@
 
 \begin{code}
 module MkIface ( 
-	mkModDetails, mkModDetailsFromIface, completeIface
+	mkModDetails, mkModDetailsFromIface, completeIface, writeIface
   ) where
 
 #include "HsVersions.h"
@@ -109,6 +109,7 @@ mkModDetailsFromIface type_env dfun_ids rules
     rule_dcls = [(id,rule) | IfaceRuleOut id rule <- rules]
 	-- All the rules from an interface are of the IfaceRuleOut form
 
+
 completeIface :: Maybe ModIface		-- The old interface, if we have it
 	      -> ModIface		-- The new one, minus the decls and versions
 	      -> ModDetails		-- The ModDetails for this module
@@ -586,3 +587,129 @@ diffDecls old_vers old_fixities new_fixities old new
     changed d nd = ptext SLIT("Changed in iface: ") <+> ((ptext SLIT("Old:") <+> ppr d) $$ 
 							 (ptext SLIT("New:") <+> ppr nd))
 \end{code}
+
+
+
+%************************************************************************
+%*				 					*
+\subsection{Writing an interface file}
+%*				 					*
+%************************************************************************
+
+\begin{code}
+writeIface :: Finder -> ModIface -> IO ()
+writeIface finder mod_iface
+  = do	{ let filename = error "... find the right file..."
+	; if_hdl <- openFile filename WriteMode
+	; printForIface if_hdl (pprIface mod_iface)
+	; hClose if_hdl
+	}
+
+pprIface iface
+ = vcat [ ptext SLIT("__interface")
+		<+> doubleQuotes (ptext opt_InPackage)
+		<+> ppr (mi_module iface) <+> ppr (vers_module version_info)
+		<+> pp_sub_vers
+		<+> (if mi_orphan iface then char '!' else empty)
+		<+> int opt_HiVersion
+		<+> ptext SLIT("where")
+
+	, pprExports (mi_exports iface)
+	, vcat (map pprUsage (mi_usages iface))
+
+	, pprIfaceDecls (vers_decls version_info) 
+			(mi_fixities iface)
+			(mi_decls iface)
+
+	, pprDeprecs (mi_deprecs iface)
+	]
+  where
+    version_info = mi_version mod_iface
+    exp_vers     = vers_exports version_info
+    rule_vers	 = vers_rules version_info
+
+    pp_sub_vers | exp_vers == initialVersion && rule_vers == initialVersion = empty
+		| otherwise = brackets (ppr exp_vers <+> ppr rule_vers)
+\end{code}
+
+When printing export lists, we print like this:
+	Avail   f		f
+	AvailTC C [C, x, y]	C(x,y)
+	AvailTC C [x, y]	C!(x,y)		-- Exporting x, y but not C
+
+\begin{code}
+pprExport :: (ModuleName, Avails) -> SDoc
+pprExport (mod, items)
+ = hsep [ ptext SLIT("__export "), ppr mod, hsep (map upp_avail items) ] <> semi
+  where
+    pp_avail :: RdrAvailInfo -> SDoc
+    pp_avail (Avail name)      = pprOccName name
+    pp_avail (AvailTC name []) = empty
+    pp_avail (AvailTC name ns) = hcat [pprOccName name, bang, upp_export ns']
+				where
+				  bang | name `elem` ns = empty
+				       | otherwise	= char '|'
+				  ns' = filter (/= name) ns
+    
+    pp_export []    = empty
+    pp_export names = braces (hsep (map pprOccName names))
+\end{code}
+
+
+\begin{code}
+pprUsage :: ImportVersion Name -> SDoc
+pprUsage (m, has_orphans, is_boot, whats_imported)
+  = hsep [ptext SLIT("import"), pprModuleName m, 
+	  pp_orphan, pp_boot,
+	  pp_versions whats_imported
+    ] <> semi
+  where
+    pp_orphan | has_orphans = char '!'
+	      | otherwise   = empty
+    pp_boot   | is_boot     = char '@'
+              | otherwise   = empty
+
+	-- Importing the whole module is indicated by an empty list
+    pp_versions NothingAtAll   		    = empty
+    pp_versions (Everything v) 		    = dcolon <+> int v
+    pp_versions (Specifically vm ve nvs vr) = dcolon <+> int vm <+> pp_export_version ve <+> int vr 
+					      <+> hsep [ ppr n <+> int v | (n,v) <- nvs ]
+
+	-- HACK for the moment: print the export-list version even if
+	-- we don't use it, so that syntax of interface files doesn't change
+    pp_export_version Nothing  = int 1
+    pp_export_version (Just v) = int v
+\end{code}
+
+\begin{code}
+pprIfaceDecls version_map fixity_map decls
+  = vcat [ vcat [ppr i <+> semi | i <- dcl_insts decls]
+	 , vcat (map ppr_decl (dcl_tycl decls))
+	 , pprRules (dcl_rules decls)
+	 ]
+  where
+    ppr_decl d  = (ppr_vers d <+> ppr d <> semi) $$ ppr_fixes d
+
+	-- Print the version for the decl
+    ppr_vers d = case lookupNameEnv version_map (tyClDeclName d) of
+		   Nothing -> empty
+		   Just v  -> int v
+
+	-- Print fixities relevant to the decl
+    ppr_fixes d = vcat (map ppr_fix (fixities d))
+    fixities d  = [ ppr fix <+> ppr n <> semi
+		  | n <- tyClDeclNames d, 
+		    [Just fix] <- lookupNameEnv fixity_map n
+		  ]
+\end{code}
+
+\begin{code}
+pprRules []    = empty
+pprRules rules = hsep [ptext SLIT("{-## __R"), vcat (map ppr rules), ptext SLIT("##-}")]
+
+pprDeprecs []   = empty
+pprDeprecs deps = hsep [ ptext SLIT("{-## __D"), guts, ptext SLIT("##-}")]
+		where
+		  guts = hsep [ ppr ie <+> doubleQuotes (ppr txt) <> semi 
+			      | Deprecation ie txt _ <- deps ]
+\end{code}
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index 0b7449a..eb18d9d 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -27,7 +27,7 @@ import RnIfaces		( slurpImpDecls, mkImportInfo,
 			)
 import RnHiFiles	( findAndReadIface, removeContext, loadExports, loadFixDecls, loadDeprecs )
 import RnEnv		( availName, availsToNameSet, 
-			  emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, sortAvails,
+			  emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, groupAvails,
 			  warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules,
 			  lookupOrigNames, lookupGlobalRn, newGlobalName
 			)
@@ -168,7 +168,7 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls
 
 
 	-- Sort the exports to make them easier to compare for versions
-	my_exports = sortAvails export_avails
+	my_exports = groupAvails export_avails
 	
 	mod_iface = ModIface {	mi_module   = this_module,
 				mi_version  = initialVersionInfo,
@@ -664,13 +664,18 @@ printMinimalImports mod_name imps
     to_ie (Avail n)       = returnRn (IEVar n)
     to_ie (AvailTC n [m]) = ASSERT( n==m ) 
 			    returnRn (IEThingAbs n)
-    to_ie (AvailTC n ns)  = getInterfaceExports (moduleName (nameModule n)) 
-						ImportBySystem	 	`thenRn` \ (_, avails) ->
-			    case [ms | AvailTC m ms <- avails, m == n] of
-			      [ms] | all (`elem` ns) ms -> returnRn (IEThingAll n)
-				   | otherwise	        -> returnRn (IEThingWith n (filter (/= n) ns))
-			      other -> pprTrace "to_ie" (ppr n <+> ppr (nameModule n) <+> ppr other) $
-				       returnRn (IEVar n)
+    to_ie (AvailTC n ns)  
+	= getInterfaceExports n_mod ImportBySystem		`thenRn` \ (_, avails_by_module) ->
+	  case [xs | (m,as) <- avails_by_module,
+		     m == n_mod,
+		     AvailTC x xs <- as, 
+		     x == n] of
+	      [xs] | all (`elem` ns) xs -> returnRn (IEThingAll n)
+		   | otherwise	        -> returnRn (IEThingWith n (filter (/= n) ns))
+	      other			-> pprTrace "to_ie" (ppr n <+> ppr (nameModule n) <+> ppr other) $
+					   returnRn (IEVar n)
+	where
+	  n_mod = moduleName (nameModule n)
 
 rnDump  :: [RenamedHsDecl] 	-- Renamed imported decls
 	-> [RenamedHsDecl] 	-- Renamed local decls
diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index 3b33542..4fc2a3a 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -27,7 +27,7 @@ import Name		( Name, NamedThing(..),
 			)
 import NameSet
 import OccName		( OccName, occNameUserString, occNameFlavour )
-import Module		( ModuleName, moduleName, mkVanillaModule )
+import Module		( ModuleName, moduleName, mkVanillaModule, mkSysModuleNameFS, moduleNameFS )
 import FiniteMap
 import Unique		( Unique )
 import UniqSupply
@@ -38,6 +38,7 @@ import Util		( sortLt )
 import List		( nub )
 import PrelNames	( mkUnboundName )
 import CmdLineOpts
+import FastString	( FastString )
 \end{code}
 
 %*********************************************************
@@ -638,18 +639,28 @@ filterAvail (IEThingAll _) avail@(AvailTC _ _)   = Just avail
 filterAvail ie avail = Nothing
 
 -------------------------------------
-sortAvails :: Avails -> Avails
-sortAvails avails = sortLt lt avails
+groupAvails :: Avails -> [(ModuleName, Avails)]
+  -- Group by module and sort by occurrence
+  -- This keeps the list in canonical order
+groupAvails avails 
+  = [ (mkSysModuleNameFS fs, sortLt lt avails)
+    | (fs,avails) <- fmToList groupFM
+    ]
   where
-    a1 `lt` a2 = mod1 < mod2 ||
-	         (mod1 == mod2 && occ1 < occ2)
+    groupFM :: FiniteMap FastString Avails
+	-- Deliberatey use the FastString so we
+	-- get a canonical ordering
+    groupFM = foldl add emptyFM avails
+
+    add env avail = addToFM_C combine env mod_fs [avail]
+		  where
+		    mod_fs = moduleNameFS (moduleName (nameModule (availName avail)))
+		    combine old _ = avail:old
+
+    a1 `lt` a2 = occ1 < occ2
 	       where
-		 name1 = availName a1
-		 name2 = availName a2
-		 mod1  = nameModule name1
-		 mod2  = nameModule name2
-		 occ1  = nameOccName name1
-		 occ2  = nameOccName name2
+		 occ1  = nameOccName (availName a1)
+		 occ2  = nameOccName (availName a2)
 				
 -------------------------------------
 pprAvail :: AvailInfo -> SDoc
diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs
index 4e067b9..9b01c3e 100644
--- a/ghc/compiler/rename/RnHiFiles.lhs
+++ b/ghc/compiler/rename/RnHiFiles.lhs
@@ -240,16 +240,16 @@ addModDeps mod new_deps mod_deps
 --	Loading the export list
 -----------------------------------------------------
 
-loadExports :: (Version, [ExportItem]) -> RnM d (Version, Avails)
+loadExports :: (Version, [ExportItem]) -> RnM d (Version, [(ModuleName,Avails)])
 loadExports (vers, items)
   = getModuleRn 				`thenRn` \ this_mod ->
     mapRn (loadExport this_mod) items		`thenRn` \ avails_s ->
-    returnRn (vers, concat avails_s)
+    returnRn (vers, avails_s)
 
 
-loadExport :: Module -> ExportItem -> RnM d [AvailInfo]
+loadExport :: Module -> ExportItem -> RnM d (ModuleName, Avails)
 loadExport this_mod (mod, entities)
-  | mod == moduleName this_mod = returnRn []
+  | mod == moduleName this_mod = returnRn (mod, [])
 	-- If the module exports anything defined in this module, just ignore it.
 	-- Reason: otherwise it looks as if there are two local definition sites
 	-- for the thing, and an error gets reported.  Easiest thing is just to
@@ -267,7 +267,8 @@ loadExport this_mod (mod, entities)
 	-- but it's a bogus thing to do!
 
   | otherwise
-  = mapRn (load_entity mod) entities
+  = mapRn (load_entity mod) entities	`thenRn` \ avails ->
+    returnRn (mod, avails)
   where
     new_name mod occ = newGlobalName mod occ
 
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index b7af688..a56da3b 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -67,7 +67,7 @@ import List		( nub )
 @getInterfaceExports@ is called only for directly-imported modules.
 
 \begin{code}
-getInterfaceExports :: ModuleName -> WhereFrom -> RnMG (Module, Avails)
+getInterfaceExports :: ModuleName -> WhereFrom -> RnMG (Module, [(ModuleName,Avails)])
 getInterfaceExports mod_name from
   = getHomeIfaceTableRn 		`thenRn` \ hit ->
     case lookupModuleEnvByName hit mod_name of {
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index a33df88..e2094c8 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -169,15 +169,19 @@ importsFromImportDecl :: (Name -> Bool)		-- OK to omit qualifier
 
 importsFromImportDecl is_unqual (ImportDecl imp_mod_name from qual_only as_mod import_spec iloc)
   = pushSrcLocRn iloc $
-    getInterfaceExports imp_mod_name from	`thenRn` \ (imp_mod, avails) ->
+    getInterfaceExports imp_mod_name from	`thenRn` \ (imp_mod, avails_by_module) ->
 
-    if null avails then
+    if null avails_by_module then
 	-- If there's an error in getInterfaceExports, (e.g. interface
 	-- file not found) we get lots of spurious errors from 'filterImports'
 	returnRn (emptyRdrEnv, mkEmptyExportAvails imp_mod_name)
     else
 
-    filterImports imp_mod_name import_spec avails   `thenRn` \ (filtered_avails, hides, explicits) ->
+    let
+	avails :: Avails
+	avails = concat (map snd avails_by_module)
+    in
+    filterImports imp_mod_name import_spec avails	`thenRn` \ (filtered_avails, hides, explicits) ->
 
     let
 	mk_provenance name = NonLocalDef (UserImport imp_mod iloc (name `elemNameSet` explicits)) 
@@ -295,7 +299,7 @@ filterImports :: ModuleName			-- The module being imported
 filterImports mod Nothing imports
   = returnRn (imports, [], emptyNameSet)
 
-filterImports mod (Just (want_hiding, import_items)) avails
+filterImports mod (Just (want_hiding, import_items)) total_avails
   = flatMapRn get_item import_items		`thenRn` \ avails_w_explicits ->
     let
 	(item_avails, explicits_s) = unzip avails_w_explicits
@@ -304,14 +308,14 @@ filterImports mod (Just (want_hiding, import_items)) avails
     if want_hiding 
     then	
 	-- All imported; item_avails to be hidden
-	returnRn (avails, item_avails, emptyNameSet)
+	returnRn (total_avails, item_avails, emptyNameSet)
     else
 	-- Just item_avails imported; nothing to be hidden
 	returnRn (item_avails, [], explicits)
   where
     import_fm :: FiniteMap OccName AvailInfo
     import_fm = listToFM [ (nameOccName name, avail) 
-			 | avail <- avails,
+			 | avail <- total_avails,
 			   name  <- availNames avail]
 	-- Even though availNames returns data constructors too,
 	-- they won't make any difference because naked entities like T