Commit bac531aa authored by simonpj's avatar simonpj
Browse files

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

writeIface stuff
parent 61663f75
......@@ -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
......
......@@ -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}
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 {
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment