#include "HsVersions.h"
module RnIfaces (
- findHiFiles,
cachedIface,
- cachedDecl,
- readIface,
+ cachedDecl, CachingResult(..),
rnIfaces,
- finalIfaceInfo,
- IfaceCache(..),
- VersionInfo(..)
+ IfaceCache, initIfaceCache
) where
-import Ubiq
+IMP_Ubiq()
-import LibDirectory
-import PreludeGlaST ( thenPrimIO, seqPrimIO, readVar, writeVar, MutableVar(..) )
+import PreludeGlaST ( thenPrimIO, newVar, readVar, writeVar, SYN_IE(MutableVar) )
+#if __GLASGOW_HASKELL__ >= 200
+# define ST_THEN `stThen`
+# define TRY_IO tryIO
+IMPORT_1_3(GHCio(stThen,tryIO))
+#else
+# define ST_THEN `thenPrimIO`
+# define TRY_IO try
+#endif
import HsSyn
import HsPragmas ( noGenPragmas )
import RnMonad
import RnSource ( rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType )
-import RnUtils ( RnEnv(..), emptyRnEnv, lookupRnEnv, lookupTcRnEnv, extendGlobalRnEnv )
+import RnUtils ( SYN_IE(RnEnv), emptyRnEnv, lookupRnEnv, lookupTcRnEnv, extendGlobalRnEnv )
import ParseIface ( parseIface )
-import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..) )
+import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..),
+ VersionsMap(..), UsagesMap(..)
+ )
-import Bag ( emptyBag, consBag, snocBag, unionBags, unionManyBags, isEmptyBag, bagToList )
-import CmdLineOpts ( opt_HiSuffix, opt_SysHiSuffix )
-import ErrUtils ( Error(..), Warning(..) )
+import Bag ( emptyBag, unitBag, consBag, snocBag,
+ unionBags, unionManyBags, isEmptyBag, bagToList )
+import ErrUtils ( SYN_IE(Error), SYN_IE(Warning) )
import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM,
- fmToList, delListFromFM, sizeFM, keysFM{-ToDo:rm-} )
-import Maybes ( maybeToBool )
-import Name ( moduleNamePair, origName, isRdrLexCon,
- RdrName(..){-instance NamedThing-}
+ fmToList, delListFromFM, sizeFM, foldFM, unitFM,
+ plusFM_C, addListToFM{-, keysFM ToDo:rm-}, FiniteMap
)
-import PprStyle -- ToDo:rm
-import Outputable -- ToDo:rm
-import PrelInfo ( builtinNameInfo )
+import Maybes ( maybeToBool, MaybeErr(..) )
+import Name ( origName, moduleOf, nameOf, qualToOrigName, OrigName(..),
+ isLexCon, RdrName(..), Name{-instance NamedThing-} )
+--import PprStyle -- ToDo:rm
+--import Outputable -- ToDo:rm
+import PrelInfo ( builtinNameMaps, builtinKeysMap, builtinTcNamesMap, SYN_IE(BuiltinNames) )
import Pretty
-import Maybes ( MaybeErr(..) )
import UniqFM ( emptyUFM )
import UniqSupply ( splitUniqSupply )
import Util ( sortLt, removeDups, cmpPString, startsWith,
- panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} )
+ panic, pprPanic, assertPanic{-, pprTrace ToDo:rm-} )
\end{code}
\begin{code}
type ModuleToIfaceContents = FiniteMap Module ParsedIface
type ModuleToIfaceFilePath = FiniteMap Module FilePath
-type IfaceCache
- = MutableVar _RealWorld (ModuleToIfaceContents,
- ModuleToIfaceFilePath)
-\end{code}
-
-*********************************************************
-* *
-\subsection{Looking for interface files}
-* *
-*********************************************************
-
-Return a mapping from module-name to
-absolute-filename-for-that-interface.
-\begin{code}
-findHiFiles :: [FilePath] -> [FilePath] -> IO (FiniteMap Module FilePath)
-
-findHiFiles dirs sysdirs
- = do_dirs emptyFM (dirs ++ sysdirs)
- where
- do_dirs env [] = return env
- do_dirs env (dir:dirs)
- = do_dir env dir >>= \ new_env ->
- do_dirs new_env dirs
- -------
- do_dir env dir
- = --trace ("Having a go on..."++dir) $
- getDirectoryContents dir >>= \ entries ->
- do_entries env entries
- where
- do_entries env [] = return env
- do_entries env (e:es)
- = do_entry env e >>= \ new_env ->
- do_entries new_env es
- -------
- do_entry env e
- = case (acceptable_hi (reverse e)) of
- Nothing -> --trace ("Deemed uncool:"++e) $
- return env
- Just mod ->
- let
- pmod = _PK_ mod
- in
- case (lookupFM env pmod) of
- Nothing -> --trace ("Adding "++mod++" -> "++e) $
- 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) $
- return env
- -------
- acceptable_hi rev_e -- looking at pathname *backwards*
- = case (startsWith (reverse opt_HiSuffix) rev_e) of
- Nothing -> Nothing
- Just xs -> plausible_modname xs{-reversed-}
-
- -------
- de_dot ('.' : '/' : xs) = xs
- de_dot xs = xs
-
- -------
- plausible_modname rev_e
- = let
- cand = reverse (takeWhile is_modname_char rev_e)
- in
- if null cand || not (isUpper (head cand))
- then Nothing
- else Just cand
- where
- is_modname_char c = isAlphanum c || c == '_'
+#if __GLASGOW_HASKELL__ >= 200
+# define REAL_WORLD RealWorld
+#else
+# define REAL_WORLD _RealWorld
+#endif
+
+data IfaceCache
+ = IfaceCache
+ Module -- the name of the module being compiled
+ BuiltinNames -- so we can avoid going after things
+ -- the compiler already knows about
+ (MutableVar REAL_WORLD
+ (ModuleToIfaceContents, -- interfaces for individual interface files
+ ModuleToIfaceContents, -- merged interfaces based on module name
+ -- used for extracting info about original names
+ ModuleToIfaceFilePath))
+
+initIfaceCache mod hi_files
+ = newVar (emptyFM,emptyFM,hi_files) ST_THEN \ iface_var ->
+ return (IfaceCache mod builtinNameMaps iface_var)
\end{code}
*********************************************************
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
+ -> Bool -- True => want merged interface for original name
+ -- False => want file interface only
+ -> FAST_STRING -- item that prompted search (debugging only!)
-> Module
-> IO (MaybeErr ParsedIface Error)
-cachedIface iface_cache mod
- = readVar iface_cache `thenPrimIO` \ (iface_fm, file_fm) ->
+cachedIface (IfaceCache _ _ iface_var) want_orig_iface item modname
+ = readVar iface_var ST_THEN \ (iface_fm, orig_fm, file_fm) ->
- case (lookupFM iface_fm mod) of
- Just iface -> return (Succeeded iface)
+ case (lookupFM iface_fm modname) of
+ Just iface -> return (want_iface iface orig_fm)
Nothing ->
- case (lookupFM file_fm mod) of
- Nothing -> return (Failed (noIfaceErr mod))
+ case (lookupFM file_fm modname) of
+ Nothing -> return (Failed (noIfaceErr modname))
Just file ->
- readIface file mod >>= \ read_iface ->
+ readIface file modname item >>= \ read_iface ->
case read_iface of
Failed err -> -- pprTrace "module-file map:\n" (ppAboves [ppCat [ppPStr m, ppStr f] | (m,f) <- fmToList file_fm]) $
return (Failed err)
Succeeded iface ->
let
- iface_fm' = addToFM iface_fm mod iface
+ iface_fm' = addToFM iface_fm modname 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_var (iface_fm', orig_fm', file_fm) ST_THEN \ _ ->
+ return (want_iface iface orig_fm')
+ where
+ want_iface iface orig_fm
+ | want_orig_iface
+ = case lookupFM orig_fm modname of
+ Nothing -> Failed (noOrigIfaceErr modname)
+ 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 files2 files1)
+ (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
+
+----------
+data CachingResult
+ = CachingFail Error -- tried to find a decl, something went wrong
+ | CachingHit RdrIfaceDecl -- got it
+ | CachingAvoided (Maybe (Either RnName RnName))
+ -- didn't look in the interface
+ -- file(s); Nothing => the thing
+ -- *should* be in the source module;
+ -- Just (Left ...) => builtin val name;
+ -- Just (Right ..) => builtin tc name
+
cachedDecl :: IfaceCache
-> Bool -- True <=> tycon or class name
- -> 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 ->
- case maybe_iface of
- Failed err -> return (Failed err)
- 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))
- where
- (mod, str) = moduleNamePair orig
+ -> OrigName
+ -> IO CachingResult
+
+cachedDecl iface_cache@(IfaceCache this_mod (b_val_names,b_tc_names) _)
+ class_or_tycon name@(OrigName mod str)
+
+ = -- pprTrace "cachedDecl:" (ppr PprDebug name) $
+ if mod == this_mod then -- some i/face has made a reference
+ return (CachingAvoided Nothing) -- to something from this module
+ else
+ let
+ b_env = if class_or_tycon then b_tc_names else b_val_names
+ in
+ case (lookupFM b_env name) of
+ Just rn -> -- in builtins!
+ return (CachingAvoided (Just ((if class_or_tycon then Right else Left) rn)))
+
+ Nothing ->
+ cachedIface iface_cache True str mod >>= \ maybe_iface ->
+ case maybe_iface of
+ Failed err -> --pprTrace "cachedDecl:fail:" (ppr PprDebug orig) $
+ return (CachingFail err)
+ Succeeded (ParsedIface _ _ _ _ _ _ exps _ _ tdefs vdefs _ _) ->
+ case (lookupFM (if class_or_tycon then tdefs else vdefs) str) of
+ Just decl -> return (CachingHit decl)
+ Nothing -> return (CachingFail (noDeclInIfaceErr mod str))
----------
cachedDeclByType :: IfaceCache
-> RnName{-NB: diff type than cachedDecl -}
- -> IO (MaybeErr RdrIfaceDecl Error)
+ -> IO CachingResult
cachedDeclByType iface_cache rn
-- the idea is: check that, e.g., if we're given an
-- RnClass, then we really get back a ClassDecl from
-- the cache (not an RnData, or something silly)
- = cachedDecl iface_cache (isRnTyConOrClass rn) (origName rn) >>= \ maybe_decl ->
+ = cachedDecl iface_cache (isRnTyConOrClass rn) (origName "cachedDeclByType" rn) >>= \ maybe_decl ->
let
return_maybe_decl = return maybe_decl
- return_failed msg = return (Failed msg)
+ return_failed msg = return (CachingFail msg)
in
case maybe_decl of
- Failed _ -> return_maybe_decl
- Succeeded if_decl ->
+ CachingAvoided _ -> return_maybe_decl
+ CachingFail io_msg -> return_failed (ifaceIoErr io_msg rn)
+ CachingHit if_decl ->
case rn of
WiredInId _ -> return_failed (ifaceLookupWiredErr "value" rn)
WiredInTyCon _ -> return_failed (ifaceLookupWiredErr "type constructor" rn)
- RnUnbound _ -> pprPanic "cachedDeclByType:" (ppr PprDebug rn)
+ RnUnbound _ -> panic "cachedDeclByType:" -- (ppr PprDebug rn)
RnSyn _ -> return_maybe_decl
RnData _ _ _ -> return_maybe_decl
\end{code}
\begin{code}
-readIface :: FilePath -> Module
- -> IO (MaybeErr ParsedIface Error)
+readIface :: FilePath -> Module -> FAST_STRING -> IO (MaybeErr ParsedIface Error)
-readIface file mod
- = readFile file `thenPrimIO` \ read_result ->
+readIface file modname item
+ = --hPutStr stderr (" reading "++file++" ("++ _UNPK_ item ++")") >>
+ TRY_IO (readFile file) >>= \ read_result ->
case read_result of
Left err -> return (Failed (cannaeReadErr file err))
- Right contents -> return (parseIface contents)
+ Right contents -> --hPutStr stderr ".." >>
+ let parsed = parseIface contents in
+ --hPutStr stderr "..\n" >>
+ return (
+ case parsed of
+ Failed _ -> parsed
+ Succeeded p -> Succeeded (init_merge modname 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}
-> IO (RenamedHsModule, -- extended module
RnEnv, -- final env (for renaming derivings)
ImplicitEnv, -- implicit names used (for usage info)
+ (UsagesMap,VersionsMap,[Module]), -- usage info
(Bag Error, Bag Warning))
rnIfaces iface_cache imp_mods us
todo
= {-
pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $
-
- pprTrace "rnIfaces:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM qual]) $
+ pprTrace "rnIfaces:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
pprTrace "rnIfaces:unqual:" (ppCat (map ppPStr (keysFM unqual))) $
- pprTrace "rnIfaces:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM tc_qual]) $
+ pprTrace "rnIfaces:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
pprTrace "rnIfaces:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
- pprTrace "rnIfaces:dqual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM dqual]) $
+ pprTrace "rnIfaces:dqual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM dqual]) $
pprTrace "rnIfaces:dunqual:" (ppCat (map ppPStr (keysFM dunqual))) $
- pprTrace "rnIfaces:dtc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (m,n) <- keysFM dtc_qual]) $
+ pprTrace "rnIfaces:dtc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM dtc_qual]) $
pprTrace "rnIfaces:dtc_unqual:"(ppCat (map ppPStr (keysFM dtc_unqual))) $
-}
if_errs_warns),
if_final_env) ->
+ -- finalize what we want to say we learned about the
+ -- things we used
+ 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
(typedecls ++ if_typedecls)
typesigs
src_loc,
if_final_env,
if_implicits,
+ usage_stuff,
if_errs_warns)
where
decls_and_insts todo def_env occ_env to_return us
- = do_decls todo -- initial batch of names to process
+ = let
+ (us1,us2) = splitUniqSupply us
+ in
+ do_decls todo -- initial batch of names to process
(def_env, occ_env, us1) -- init stuff down
to_return -- acc results
>>= \ (decls_return,
do_insts decls_def_env decls_occ_env emptyRnEnv emptyFM
(add_errs errs decls_return) us2
- where
- (us1,us2) = splitUniqSupply us
+ --------
do_insts def_env occ_env prev_env done_insts to_return us
| size_tc_env occ_env == size_tc_env prev_env
= return (to_return, occ_env)
-- pprTrace "do_decls:done:" (ppr PprDebug n) $
do_decls ns down to_return
- Nothing -> -- OK, see what the cache has for us...
+ Nothing
+ | moduleOf (origName "do_decls" 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_warn (thisModImplicitWarn 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
+ CachingAvoided _ ->
+ --pprTrace "do_decls:caching avoided:" (ppr PprDebug n) $
+ do_decls ns down to_return
+
+ CachingFail err -> -- add the error, but keep going:
+ --pprTrace "do_decls:cache error:" (ppr PprDebug n) $
+ do_decls ns down (add_err err to_return)
+
+ CachingHit 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;
)
lookup_defd (def_env, _, _) n
- | isRnTyConOrClass n
- = lookupTcRnEnv def_env (origName n)
- | otherwise
- = lookupRnEnv def_env (origName n)
+ = (if isRnTyConOrClass n then lookupTcRnEnv else lookupRnEnv) def_env
+ (case (origName "lookup_defd" n) of { OrigName m s -> Qual m s })
+ -- this is hack because we are reusing the RnEnv technology
defenv (def_env, _, _) = def_env
occenv (_, occ_env, _) = occ_env
add_occs (val_defds, tc_defds) (val_imps, tc_imps) (def_env, occ_env, us)
= case (extendGlobalRnEnv def_env val_defds tc_defds) of { (new_def_env, def_dups) ->
- ASSERT(isEmptyBag def_dups)
+ --(if isEmptyBag def_dups then \x->x else pprTrace "add_occs:" (ppCat [ppr PprDebug n | (n,_,_) <- bagToList def_dups])) $
+-- ASSERT(isEmptyBag def_dups)
let
- val_occs = val_defds ++ fmToList val_imps
- tc_occs = tc_defds ++ fmToList tc_imps
+ de_orig imps = [ (Qual m n, v) | (OrigName m n, v) <- fmToList imps ]
+ -- again, this hackery because we are reusing the RnEnv technology
+
+ val_occs = val_defds ++ de_orig val_imps
+ tc_occs = tc_defds ++ de_orig tc_imps
in
case (extendGlobalRnEnv occ_env val_occs tc_occs) of { (new_occ_env, occ_dups) ->
= ((tydecls, classdecls, is ++ instdecls, sigs), implicit, msgs)
add_implicits (val_imps, tc_imps) (decls, (val_fm, tc_fm), msgs)
- = (decls, (val_fm `plusFM` val_imps, tc_fm `plusFM` tc_imps), msgs)
+ = (decls, (val_fm `plusFM` val_imps, tc_fm `plusFM` tc_imps), msgs)
add_err err (decls,implicit,(errs,warns)) = (decls,implicit,(errs `snocBag` err,warns))
add_errs ers (decls,implicit,(errs,warns)) = (decls,implicit,(errs `unionBags` ers,warns))
+add_warn wrn (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `snocBag` wrn))
add_warns ws (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `unionBags` ws))
\end{code}
| AddedSig RenamedSig
rnIfaceDecl :: RdrIfaceDecl
- -> RnM_Fixes _RealWorld
+ -> RnM_Fixes REAL_WORLD
(AddedDecl, -- the resulting decl to add to the pot
([(RdrName,RnName)], [(RdrName,RnName)]),
-- new val/tycon-class names that have
sub :: ImplicitEnv -> ([(RdrName,RnName)], [(RdrName,RnName)]) -> ImplicitEnv
sub (val_ment, tc_ment) (val_defds, tc_defds)
- = (delListFromFM val_ment (map fst val_defds),
- delListFromFM tc_ment (map fst tc_defds))
+ = (delListFromFM val_ment (map (qualToOrigName . fst) val_defds),
+ delListFromFM tc_ment (map (qualToOrigName . fst) tc_defds))
\end{code}
% ------------------------------
\begin{code}
cacheInstModules :: IfaceCache -> [Module] -> IO (Bag Error)
-cacheInstModules iface_cache imp_mods
- = readVar iface_cache `thenPrimIO` \ (iface_fm, _) ->
+
+cacheInstModules iface_cache@(IfaceCache _ _ iface_var) imp_mods
+ = readVar iface_var ST_THEN \ (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 ->
+ --pprTrace "cacheInstModules:" (ppCat (map ppPStr imp_imods)) $
+ accumulate (map (cachedIface iface_cache False SLIT("instance_modules")) 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_var ST_THEN \ (all_iface_fm, _, _) ->
let
all_ifaces = eltsFM all_iface_fm
(all_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims (all_ifaces))))
@rnIfaceInstStuff@: Deal with instance declarations from interface files.
\begin{code}
-type InstanceEnv = FiniteMap (RdrName, RdrName) Int
+type InstanceEnv = FiniteMap (OrigName, OrigName) Int
rnIfaceInstStuff
:: IfaceCache -- all about ifaces we've read
RnEnv, -- final occ env
[RnName]) -- new unknown names
-rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return
+rnIfaceInstStuff iface_cache@(IfaceCache _ _ iface_var) modname us occ_env done_inst_env to_return
= -- 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_var ST_THEN \ (_, orig_iface_fm, _) ->
let
- all_ifaces = eltsFM iface_fm
- all_insts = unionManyBags (map get_insts all_ifaces)
- interesting_insts = filter want_inst (bagToList all_insts)
+ all_ifaces = eltsFM orig_iface_fm
+ all_insts = concat (map get_insts all_ifaces)
+ interesting_insts = filter want_inst all_insts
-- Sanity Check:
-- Assert that there are no more instances for the done instances
- claim_done = filter is_done_inst (bagToList all_insts)
+ claim_done = filter is_done_inst all_insts
claim_done_env = foldr add_done_inst emptyFM claim_done
+
has_val fm (k,i) = case lookupFM fm k of { Nothing -> False; Just v -> i == v }
in
{-
case (initRn False{-iface-} modname occ_env us (
setExtraRn emptyUFM{-no fixities-} $
mapRn rnIfaceInst interesting_insts `thenRn` \ insts ->
- getImplicitUpRn `thenRn` \ implicits ->
+ getImplicitUpRn `thenRn` \ implicits ->
returnRn (insts, implicits))) of {
((if_insts, if_implicits), if_errs, if_warns) ->
eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits))
}
where
- get_insts (ParsedIface _ _ _ _ _ _ _ _ _ insts _) = insts
+ get_insts (ParsedIface imod _ _ _ _ _ _ _ _ _ _ insts _) = [(imod, inst) | inst <- bagToList insts]
- add_done_inst (InstSig clas tycon _ _) inst_env
- = addToFM_C (+) inst_env (tycon,clas) 1
+ tycon_class clas tycon = (qualToOrigName clas, qualToOrigName tycon)
- is_done_inst (InstSig clas tycon _ _)
- = maybeToBool (lookupFM done_inst_env (tycon,clas))
+ add_done_inst (_, InstSig clas tycon _ _) inst_env
+ = addToFM_C (+) inst_env (tycon_class clas tycon) 1
+
+ is_done_inst (_, InstSig clas tycon _ _)
+ = maybeToBool (lookupFM done_inst_env (tycon_class clas tycon))
add_imp_occs (val_imps, tc_imps) occ_env
- = case extendGlobalRnEnv occ_env (fmToList val_imps) (fmToList tc_imps) of
+ = case (extendGlobalRnEnv occ_env (de_orig val_imps) (de_orig tc_imps)) of
(ext_occ_env, occ_dups) -> ASSERT(isEmptyBag occ_dups)
ext_occ_env
+ where
+ de_orig imps = [ (Qual m n, v) | (OrigName m n, v) <- fmToList imps ]
+ -- again, this hackery because we are reusing the RnEnv technology
- want_inst i@(InstSig clas tycon _ _)
+ want_inst i@(imod, InstSig clas tycon _ _)
= -- it's a "good instance" (one to hang onto) if we have a
-- chance of referring to *both* the class and tycon later on ...
-
+ --pprTrace "want_inst:" (ppCat [ppr PprDebug clas, ppr PprDebug tycon, ppr PprDebug (mentionable tycon), ppr PprDebug (mentionable clas), ppr PprDebug(is_done_inst i)]) $
mentionable tycon && mentionable clas && not (is_done_inst i)
where
mentionable nm
= case lookupTcRnEnv occ_env nm of
Just _ -> True
Nothing -> -- maybe it's builtin
- case nm of
- Qual _ _ -> False
- Unqual n ->
- case (lookupFM b_tc_names n) of
- Just _ -> True
- Nothing -> maybeToBool (lookupFM b_keys n)
-
- (b_tc_names, b_keys) -- pretty UGLY ...
- = case builtinNameInfo of ((_,builtin_tcs),b_keys,_) -> (builtin_tcs,b_keys)
-
- ppr_insts insts
- = ppAboves (map ppr_inst insts)
- where
- ppr_inst (InstSig c t _ inst_decl)
- = ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug inst_decl]
+ let orig = qualToOrigName nm in
+ case (lookupFM builtinTcNamesMap orig) of
+ Just _ -> True
+ Nothing -> maybeToBool (lookupFM builtinKeysMap orig)
\end{code}
\begin{code}
-rnIfaceInst :: RdrIfaceInst -> RnM_Fixes _RealWorld RenamedInstDecl
+rnIfaceInst :: (Module, RdrIfaceInst) -> RnM_Fixes REAL_WORLD RenamedInstDecl
-rnIfaceInst (InstSig _ _ _ inst_decl) = rnInstDecl inst_decl
+rnIfaceInst (imod, InstSig _ _ _ inst_decl) = rnInstDecl (inst_decl imod)
\end{code}
\begin{code}
+type BigMaps = (FiniteMap Module Version, -- module-version map
+ FiniteMap (FAST_STRING,Module) Version) -- ordinary version map
+
finalIfaceInfo ::
IfaceCache -- iface cache
- -> [RnName] -- all imported names required
- -> [Module] -- directly imported modules
- -> IO (VersionInfo, -- info about version numbers
+ -> Module -- this module's name
+ -> RnEnv
+ -> [RenamedInstDecl]
+-- -> [RnName] -- all imported names required
+-- -> [Module] -- directly imported modules
+ -> IO (UsagesMap,
+ VersionsMap, -- info about version numbers
[Module]) -- special instance modules
-type VersionInfo = [(Module, Version, [(FAST_STRING, Version)])]
+finalIfaceInfo iface_cache@(IfaceCache _ _ iface_var) 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))) $
+ readVar iface_var ST_THEN \ (_, orig_iface_fm, _) ->
+ let
+ all_ifaces = eltsFM orig_iface_fm
+ -- all the interfaces we have looked at
+
+ big_maps
+ -- combine all the version maps we have seen into maps to
+ -- (a) lookup a module-version number, lookup an entity's
+ -- individual version number
+ = foldr mk_map (emptyFM,emptyFM) all_ifaces
+
+ val_stuff@(val_usages, val_versions)
+ = foldFM (process_item big_maps) (emptyFM, emptyFM){-init-} qual
+
+ (all_usages, all_versions)
+ = foldFM (process_item big_maps) val_stuff{-keep going-} tc_qual
+ in
+ return (all_usages, all_versions, [])
+ where
+ mk_map (ParsedIface m _ mv _ _ vers _ _ _ _ _ _ _) (mv_map, ver_map)
+ = (addToFM mv_map m mv, -- add this module
+ addListToFM ver_map [ ((n,m), v) | (n,v) <- fmToList vers ])
+
+ -----------------------
+ process_item :: BigMaps
+ -> (FAST_STRING,Module) -> RnName -- RnEnv (QualNames) components
+ -> (UsagesMap, VersionsMap) -- input
+ -> (UsagesMap, VersionsMap) -- output
+
+ process_item (big_mv_map, big_version_map) key@(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"
+ = case (add_to_usages usages key) of
+ Nothing -> as_before
+ Just new_usages -> (new_usages, versions)
+ where
+ add_to_usages usages key@(n,m)
+ = case (lookupFM big_mv_map m) of
+ Nothing -> Nothing
+ Just mv ->
+ case (lookupFM big_version_map key) of
+ Nothing -> Nothing
+ Just kv ->
+ Just $ addToFM usages m (
+ case (lookupFM usages m) of
+ Nothing -> -- nothing for this module yet...
+ (mv, unitFM n kv)
+
+ Just (mversion, mstuff) -> -- the "new" stuff will shadow the old
+ ASSERT(mversion == mv)
+ (mversion, addToFM mstuff n kv)
+ )
+
+ irrelevant (RnConstr _ _) = True -- We don't report these in their
+ irrelevant (RnField _ _) = True -- own right in usages/etc.
+ irrelevant (RnClassOp _ _) = True
+ irrelevant (RnImplicit n) = isLexCon (nameOf (origName "irrelevant" n)) -- really a RnConstr
+ irrelevant _ = False
-finalIfaceInfo iface_cache imps_reqd imp_mods
- = return ([], [])
\end{code}
\begin{code}
+thisModImplicitWarn mod n sty
+ = ppBesides [ppPStr SLIT("An interface has an implicit need of "), ppr sty n, ppPStr SLIT("; assuming this module will provide it.")]
+
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]
= ppBesides [ppPStr SLIT("Why am I looking up a wired-in "), ppStr msg, ppChar ':', ppr sty n]
badIfaceLookupErr msg name decl sty
- = ppBesides [ppPStr SLIT("Expected a "), ppStr msg, ppPStr SLIT(" declaration, but got this: ???")]
+ = ppBesides [ppPStr SLIT("Expected a "), ppStr msg, ppStr " declaration, but got this: ???"]
+
+ifaceIoErr io_msg rn sty
+ = ppBesides [io_msg sty, ppStr "; looking for: ", ppr sty rn]
\end{code}
projects / ghc-hetmet.git / blobdiff