diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs
index 9150218ec869e757ad039ad94164ae19663b9f86..9a977285fc663164080b1b1ded38e987478e8756 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 128bcf74be53f427be52fcff98b5a95263bd69b2..c9111329ae688999b5c06eb4b432e438a9486816 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 0b7449a68d468f48f24db98bfc310716f7cccf21..eb18d9d9a1a5c13c6f9c2232d6973e6b6ae7e43d 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 3b33542f14fb6ae4e4428fe3705b377b24c07c68..4fc2a3ab98cca5014de26f552ee1606e3b2c3fea 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 4e067b9de5261c27e8e7de482040095b37d2be5b..9b01c3e77027df4ad3f94939454bb4c9d087fa98 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 b7af688af7e8f47a2ff2001974d43fd12879590e..a56da3b240449171dee2e7471161d1c2596c8657 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 a33df882cb40023c58ecaf972562c3c6398601c1..e2094c810071b7e7abac69a23357eba6e2501df5 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