VersionsMap(..), UsagesMap(..)
)
-import Bag ( emptyBag, consBag, snocBag, unionBags, unionManyBags, isEmptyBag, bagToList )
+import Bag ( emptyBag, unitBag, consBag, snocBag,
+ unionBags, unionManyBags, isEmptyBag, bagToList )
import CmdLineOpts ( opt_HiSuffix, opt_SysHiSuffix )
import ErrUtils ( Error(..), Warning(..) )
import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM,
- fmToList, delListFromFM, sizeFM, keysFM{-ToDo:rm-}
+ fmToList, delListFromFM, sizeFM, foldFM, unitFM,
+ plusFM_C, keysFM{-ToDo:rm-}
)
import Maybes ( maybeToBool )
-import Name ( moduleNamePair, origName, isRdrLexCon,
- RdrName(..){-instance NamedThing-}
- )
+import Name ( moduleNamePair, origName, isRdrLexCon, RdrName(..) )
import PprStyle -- ToDo:rm
import Outputable -- ToDo:rm
import PrelInfo ( builtinNameInfo )
type ModuleToIfaceFilePath = FiniteMap Module FilePath
type IfaceCache
- = MutableVar _RealWorld (ModuleToIfaceContents,
- ModuleToIfaceFilePath)
+ = MutableVar _RealWorld
+ (ModuleToIfaceContents, -- interfaces for individual interface files
+ ModuleToIfaceContents, -- merged interfaces based on module name
+ -- used for extracting info about original names
+ ModuleToIfaceFilePath)
\end{code}
*********************************************************
findHiFiles :: [FilePath] -> [FilePath] -> IO (FiniteMap Module FilePath)
findHiFiles dirs sysdirs
- = hPutStr stderr " findHiFiles " >>
+ = --hPutStr stderr " findHiFiles " >>
do_dirs emptyFM (dirs ++ sysdirs) >>= \ result ->
- hPutStr stderr " done\n" >>
+ --hPutStr stderr " done\n" >>
return result
where
do_dirs env [] = return env
do_dirs new_env dirs
-------
do_dir env dir
- = hPutStr stderr "D" >>
+ = --hPutStr stderr "D" >>
getDirectoryContents dir >>= \ entries ->
do_entries env entries
where
do_entry env e
= case (acceptable_hi (reverse e)) of
Nothing -> --trace ("Deemed uncool:"++e) $
- hPutStr stderr "." >>
+ --hPutStr stderr "." >>
return env
Just mod ->
let
in
case (lookupFM env pmod) of
Nothing -> --trace ("Adding "++mod++" -> "++e) $
- hPutStr stderr "!" >>
+ --hPutStr stderr "!" >>
return (addToFM env pmod (dir ++ '/':e))
-- ToDo: use DIR_SEP, not /
Just xx -> ( if de_dot xx /= e then trace ("Already mapped!! "++mod++" -> "++xx++"; ignoring:"++e) else id) $
- hPutStr stderr "." >>
+ --hPutStr stderr "." >>
return env
-------
acceptable_hi rev_e -- looking at pathname *backwards*
read the interface (using our @ModuleToIfaceFilePath@ map
to decide where to look).
+Note: we have two notions of interface
+ * the interface for a particular file name
+ * the (combined) interface for a particular module name
+
+The idea is that two source files may declare a module
+with the same name with the declarations being merged.
+
+This allows us to have file PreludeList.hs producing
+PreludeList.hi but defining part of module Prelude.
+When PreludeList is imported its contents will be
+added to Prelude. In this way all the original names
+for a particular module will be available the imported
+decls are renamed.
+
+ToDo: Check duplicate definitons are the same.
+ToDo: Check/Merge duplicate pragmas.
+
+
\begin{code}
-cachedIface :: IfaceCache
+cachedIface :: Bool -- True => want merged interface for original name
+ -> IfaceCache -- False => want file interface only
-> Module
-> IO (MaybeErr ParsedIface Error)
-cachedIface iface_cache mod
- = readVar iface_cache `thenPrimIO` \ (iface_fm, file_fm) ->
+cachedIface want_orig_iface iface_cache mod
+ = readVar iface_cache `thenPrimIO` \ (iface_fm, orig_fm, file_fm) ->
case (lookupFM iface_fm mod) of
- Just iface -> return (Succeeded iface)
+ Just iface -> return (want_iface iface orig_fm)
Nothing ->
case (lookupFM file_fm mod) of
Nothing -> return (Failed (noIfaceErr mod))
Succeeded iface ->
let
iface_fm' = addToFM iface_fm mod iface
+ orig_fm' = addToFM_C mergeIfaces orig_fm (iface_mod iface) iface
in
- writeVar iface_cache (iface_fm', file_fm) `seqPrimIO`
- return (Succeeded iface)
+ writeVar iface_cache (iface_fm', orig_fm', file_fm) `seqPrimIO`
+ return (want_iface iface orig_fm')
+ where
+ want_iface iface orig_fm
+ | want_orig_iface
+ = case lookupFM orig_fm mod of
+ Nothing -> Failed (noOrigIfaceErr mod)
+ Just orig_iface -> Succeeded orig_iface
+ | otherwise
+ = Succeeded iface
+
+ iface_mod (ParsedIface mod _ _ _ _ _ _ _ _ _ _ _ _) = mod
+
+----------
+mergeIfaces (ParsedIface mod1 (_, files1) _ _ _ _ _ _ fixes1 tdefs1 vdefs1 idefs1 prags1)
+ (ParsedIface mod2 (_, files2) _ _ _ _ _ _ fixes2 tdefs2 vdefs2 idefs2 prags2)
+ = pprTrace "mergeIfaces:" (ppCat [ppStr "import", ppCat (map ppPStr (bagToList files2)),
+ ppStr "merged with", ppPStr mod1]) $
+ ASSERT(mod1 == mod2)
+ ParsedIface mod1
+ (True, unionBags files1 files2)
+ (panic "mergeIface: module version numbers")
+ (panic "mergeIface: source version numbers") -- Version numbers etc must be extracted from
+ (panic "mergeIface: usage version numbers") -- the merged file interfaces named above
+ (panic "mergeIface: decl version numbers")
+ (panic "mergeIface: exports")
+ (panic "mergeIface: instance modules")
+ (plusFM_C (dup_merge "fixity" (ppr PprDebug . fixDeclName)) fixes1 fixes2)
+ (plusFM_C (dup_merge "tycon/class" (ppr PprDebug . idecl_nm)) tdefs1 tdefs2)
+ (plusFM_C (dup_merge "value" (ppr PprDebug . idecl_nm)) vdefs1 vdefs2)
+ (unionBags idefs1 idefs2)
+ (plusFM_C (dup_merge "pragma" ppStr) prags1 prags2)
+ where
+ dup_merge str ppr_dup dup1 dup2
+ = pprTrace "mergeIfaces:"
+ (ppCat [ppPStr mod1, ppPStr mod2, ppStr ": dup", ppStr str, ppStr "decl",
+ ppr_dup dup1, ppr_dup dup2]) $
+ dup2
+
+ idecl_nm (TypeSig n _ _) = n
+ idecl_nm (NewTypeSig n _ _ _) = n
+ idecl_nm (DataSig n _ _ _ _) = n
+ idecl_nm (ClassSig n _ _ _) = n
+ idecl_nm (ValSig n _ _) = n
----------
cachedDecl :: IfaceCache
-> RdrName
-> IO (MaybeErr RdrIfaceDecl Error)
--- ToDo: this is where the check for Prelude.map being
--- located in PreludeList.map should be done ...
-
cachedDecl iface_cache class_or_tycon orig
- = cachedIface iface_cache mod >>= \ maybe_iface ->
+ = cachedIface True iface_cache mod >>= \ maybe_iface ->
case maybe_iface of
Failed err -> return (Failed err)
- Succeeded (ParsedIface _ _ _ _ _ exps _ _ tdefs vdefs _ _) ->
+ Succeeded (ParsedIface _ _ _ _ _ _ exps _ _ tdefs vdefs _ _) ->
case (lookupFM (if class_or_tycon then tdefs else vdefs) str) of
Just decl -> return (Succeeded decl)
Nothing -> return (Failed (noDeclInIfaceErr mod str))
-> IO (MaybeErr ParsedIface Error)
readIface file mod
- = hPutStr stderr (" reading "++file) >>
+ = --hPutStr stderr (" reading "++file) >>
readFile file `thenPrimIO` \ read_result ->
case read_result of
Left err -> return (Failed (cannaeReadErr file err))
- Right contents -> hPutStr stderr " parsing" >>
+ Right contents -> --hPutStr stderr " parsing" >>
let parsed = parseIface contents in
- hPutStr stderr " done\n" >>
- return parsed
+ --hPutStr stderr " done\n" >>
+ return (
+ case parsed of
+ Failed _ -> parsed
+ Succeeded p -> Succeeded (init_merge mod p)
+ )
+ where
+ init_merge this (ParsedIface mod _ v sv us vs exps insts fixes tdefs vdefs idefs prags)
+ = ParsedIface mod (False, unitBag this) v sv us vs exps insts fixes tdefs vdefs idefs prags
\end{code}
-- finalize what we want to say we learned about the
-- things we used
- finalIfaceInfo iface_cache if_final_env if_instdecls {-all_imports_used imp_mods-} >>=
+ finalIfaceInfo iface_cache modname if_final_env if_instdecls {-all_imports_used imp_mods-} >>=
\ usage_stuff@(usage_info, version_info, instance_mods) ->
return (HsModule modname iface_version exports imports fixities
-- pprTrace "do_decls:done:" (ppr PprDebug n) $
do_decls ns down to_return
- Nothing -> -- OK, see what the cache has for us...
+ Nothing
+ | fst (moduleNamePair n) == modname ->
+ -- avoid looking in interface for the module being compiled
+ -- pprTrace "do_decls:this module error:" (ppr PprDebug n) $
+ do_decls ns down (add_err (thisModImplicitErr modname n) to_return)
- cachedDeclByType iface_cache n >>= \ maybe_ans ->
- case maybe_ans of
- Failed err -> -- add the error, but keep going:
- -- pprTrace "do_decls:cache error:" (ppr PprDebug n) $
- do_decls ns down (add_err err to_return)
+ | otherwise ->
+ -- OK, see what the cache has for us...
- Succeeded iface_decl -> -- something needing renaming!
- let
+ cachedDeclByType iface_cache n >>= \ maybe_ans ->
+ case maybe_ans of
+ Failed err -> -- add the error, but keep going:
+ -- pprTrace "do_decls:cache error:" (ppr PprDebug n) $
+ do_decls ns down (add_err err to_return)
+
+ Succeeded iface_decl -> -- something needing renaming!
+ let
(us1, us2) = splitUniqSupply (uniqsupply down)
- in
- case (initRn False{-iface-} modname (occenv down) us1 (
+ in
+ case (initRn False{-iface-} modname (occenv down) us1 (
setExtraRn emptyUFM{-no fixities-} $
rnIfaceDecl iface_decl)) of {
((if_decl, if_defd, if_implicits), if_errs, if_warns) ->
add_implicits if_implicits $
add_errs if_errs $
add_warns if_warns to_return)
- }
+ }
-----------
type Go_Down = (RnEnv, -- stuff we already have defns for;
\begin{code}
cacheInstModules :: IfaceCache -> [Module] -> IO (Bag Error)
cacheInstModules iface_cache imp_mods
- = readVar iface_cache `thenPrimIO` \ (iface_fm, _) ->
+ = readVar iface_cache `thenPrimIO` \ (iface_fm, _, _) ->
let
imp_ifaces = [ iface | Just iface <- map (lookupFM iface_fm) imp_mods ]
(imp_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims imp_ifaces)))
- get_ims (ParsedIface _ _ _ _ _ _ ims _ _ _ _ _) = ims
+ get_ims (ParsedIface _ _ _ _ _ _ _ ims _ _ _ _ _) = ims
in
- accumulate (map (cachedIface iface_cache) imp_imods) >>= \ err_or_ifaces ->
+ accumulate (map (cachedIface False iface_cache) imp_imods) >>= \ err_or_ifaces ->
-- Sanity Check:
-- Assert that instance modules given by direct imports contains
-- instance modules extracted from all visited modules
- readVar iface_cache `thenPrimIO` \ (all_iface_fm, _) ->
+ readVar iface_cache `thenPrimIO` \ (all_iface_fm, _, _) ->
let
all_ifaces = eltsFM all_iface_fm
(all_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims (all_ifaces))))
= -- all the instance decls we might even want to consider
-- are in the ParsedIfaces that are in our cache
- readVar iface_cache `thenPrimIO` \ (iface_fm, _) ->
+ readVar iface_cache `thenPrimIO` \ (_, orig_iface_fm, _) ->
let
- all_ifaces = eltsFM iface_fm
+ all_ifaces = eltsFM orig_iface_fm
all_insts = unionManyBags (map get_insts all_ifaces)
interesting_insts = filter want_inst (bagToList all_insts)
eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits))
}
where
- get_insts (ParsedIface _ _ _ _ _ _ _ _ _ _ insts _) = insts
+ get_insts (ParsedIface _ _ _ _ _ _ _ _ _ _ _ insts _) = insts
add_done_inst (InstSig clas tycon _ _) inst_env
= addToFM_C (+) inst_env (tycon,clas) 1
\begin{code}
finalIfaceInfo ::
IfaceCache -- iface cache
+ -> Module -- this module's name
-> RnEnv
-> [RenamedInstDecl]
-- -> [RnName] -- all imported names required
VersionsMap, -- info about version numbers
[Module]) -- special instance modules
-finalIfaceInfo iface_cache if_final_env@((qual, unqual, tc_qual, tc_unqual), stack) if_instdecls
+finalIfaceInfo iface_cache modname if_final_env@((qual, unqual, tc_qual, tc_unqual), stack) if_instdecls
=
pprTrace "usageIf:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
-- pprTrace "usageIf:unqual:" (ppCat (map ppPStr (keysFM unqual))) $
pprTrace "usageIf:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
-- pprTrace "usageIf:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
+ let
+ val_stuff@(val_usages, val_versions)
+ = foldFM process_item (emptyFM, emptyFM){-init-} qual
- return (emptyFM, emptyFM, [])
+ (all_usages, all_versions)
+ = foldFM process_item val_stuff{-keep going-} tc_qual
+ in
+ return (all_usages, all_versions, [])
+ where
+ process_item :: (FAST_STRING,Module) -> RnName -- RnEnv (QualNames) components
+ -> (UsagesMap, VersionsMap) -- input
+ -> (UsagesMap, VersionsMap) -- output
+
+ process_item (n,m) rn as_before@(usages, versions)
+ | irrelevant rn
+ = as_before
+ | m == modname -- this module => add to "versions"
+ = (usages, addToFM versions n 1{-stub-})
+ | otherwise -- from another module => add to "usages"
+ = (add_to_usages usages m n 1{-stub-}, versions)
+
+ irrelevant (RnConstr _ _) = True -- We don't report these in their
+ irrelevant (RnField _ _) = True -- own right in usages/etc.
+ irrelevant (RnClassOp _ _) = True
+ irrelevant _ = False
+
+ add_to_usages usages m n version
+ = addToFM usages m (
+ case (lookupFM usages m) of
+ Nothing -> -- nothing for this module yet...
+ (1{-stub-}, unitFM n version)
+
+ Just (mversion, mstuff) -> -- the "new" stuff will shadow the old
+ (mversion, addToFM mstuff n version)
+ )
\end{code}
\begin{code}
+thisModImplicitErr mod n sty
+ = ppCat [ppPStr SLIT("Implicit import of"), ppr sty n, ppPStr SLIT("when compiling"), ppPStr mod]
+
noIfaceErr mod sty
= ppCat [ppPStr SLIT("Could not find interface for:"), ppPStr mod]
+noOrigIfaceErr mod sty
+ = ppCat [ppPStr SLIT("Could not find original interface for:"), ppPStr mod]
+
noDeclInIfaceErr mod str sty
= ppBesides [ppPStr SLIT("Could not find interface declaration of: "),
ppPStr mod, ppStr ".", ppPStr str]
projects / ghc-hetmet.git / blobdiff