\begin{code}
module RnHiFiles (
- findAndReadIface, loadInterface, loadHomeInterface,
+ readIface, findAndReadIface, loadInterface, loadHomeInterface,
tryLoadInterface, loadOrphanModules,
loadExports, loadFixDecls, loadDeprecs,
#include "HsVersions.h"
-import CmdLineOpts ( opt_IgnoreIfacePragmas )
-import HscTypes
+import CmdLineOpts ( DynFlag(..), opt_IgnoreIfacePragmas )
+import HscTypes ( ModuleLocation(..),
+ ModIface(..), emptyModIface,
+ VersionInfo(..),
+ lookupIfaceByModName,
+ ImportVersion, WhetherHasOrphans, IsBootInterface,
+ DeclsMap, GatedDecl, IfaceInsts, IfaceRules,
+ AvailInfo, GenAvailInfo(..), Avails, Deprecations(..)
+ )
import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..),
HsType(..), ConDecl(..),
FixitySig(..), RuleDecl(..),
import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl,
extractHsTyRdrNames
)
-import BasicTypes ( Version )
+import BasicTypes ( Version, defaultFixity )
import RnEnv
import RnMonad
import ParseIface ( parseIface, IfaceStuff(..) )
import Name ( Name {-instance NamedThing-}, nameOccName,
- nameModule,
+ nameModule, isLocalName, nameIsLocalOrFrom,
NamedThing(..),
- mkNameEnv, extendNameEnv
)
-import Module ( Module,
+import Name ( mkNameEnv, extendNameEnv )
+import Module ( Module,
moduleName, isModuleInThisPackage,
ModuleName, WhereFrom(..),
- extendModuleEnv, lookupModuleEnvByName,
+ extendModuleEnv, mkVanillaModule
)
import RdrName ( RdrName, rdrNameOcc )
import NameSet
-import SrcLoc ( mkSrcLoc, SrcLoc )
-import Maybes ( maybeToBool )
+import SrcLoc ( mkSrcLoc )
+import Maybes ( maybeToBool, orElse )
import StringBuffer ( hGetStringBuffer )
import FastString ( mkFastString )
import ErrUtils ( Message )
+import Finder ( findModule )
+import Util ( unJust )
import Lex
import FiniteMap
import Outputable
import Bag
+
+import Monad ( when )
\end{code}
%*********************************************************
\begin{code}
-loadHomeInterface :: SDoc -> Name -> RnM d Ifaces
+loadHomeInterface :: SDoc -> Name -> RnM d ModIface
loadHomeInterface doc_str name
- = loadInterface doc_str (moduleName (nameModule name)) ImportBySystem
+ = ASSERT2( not (isLocalName name), ppr name <+> parens doc_str )
+ loadInterface doc_str (moduleName (nameModule name)) ImportBySystem
loadOrphanModules :: [ModuleName] -> RnM d ()
loadOrphanModules mods
load mod = loadInterface (mk_doc mod) mod ImportBySystem
mk_doc mod = ppr mod <+> ptext SLIT("is a orphan-instance module")
-loadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d Ifaces
+loadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d ModIface
loadInterface doc mod from
= tryLoadInterface doc mod from `thenRn` \ (ifaces, maybe_err) ->
case maybe_err of
Nothing -> returnRn ifaces
Just err -> failWithRn ifaces err
-tryLoadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d (Ifaces, Maybe Message)
- -- Returns (Just err) if an error happened
- -- Guarantees to return with iImpModInfo m --> (..., True)
- -- (If the load fails, we plug in a vanilla placeholder)
+tryLoadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d (ModIface, Maybe Message)
+ -- Returns (Just err) if an error happened
+ -- It *doesn't* add an error to the monad, because sometimes it's ok to fail...
+ -- Specifically, when we read the usage information from an interface file,
+ -- we try to read the interfaces it mentions. But it's OK to fail; perhaps
+ -- the module has changed, and that interface is no longer used.
+
+ -- tryLoadInterface guarantees to return with iImpModInfo m --> (..., True)
+ -- (If the load fails, we plug in a vanilla placeholder)
tryLoadInterface doc_str mod_name from
= getHomeIfaceTableRn `thenRn` \ hit ->
- getIfacesRn `thenRn` \ ifaces ->
+ getIfacesRn `thenRn` \ ifaces@(Ifaces { iPIT = pit }) ->
- -- Check whether we have it already in the home package
- case lookupModuleEnvByName hit mod_name of {
- Just _ -> returnRn (ifaces, Nothing) ; -- In the home package
- Nothing ->
+ -- CHECK WHETHER WE HAVE IT ALREADY
+ case lookupIfaceByModName hit pit mod_name of {
+ Just iface -> returnRn (iface, Nothing) ; -- Already loaded
+ Nothing ->
let
mod_map = iImpModInfo ifaces
hi_boot_file
= case (from, mod_info) of
- (ImportByUser, _) -> False -- Not hi-boot
- (ImportByUserSource, _) -> True -- hi-boot
- (ImportBySystem, Just (_, is_boot, _)) -> is_boot --
- (ImportBySystem, Nothing) -> False
+ (ImportByUser, _) -> False -- Not hi-boot
+ (ImportByUserSource, _) -> True -- hi-boot
+ (ImportBySystem, Just (_, is_boot)) -> is_boot
+ (ImportBySystem, Nothing) -> False
-- We're importing a module we know absolutely
-- nothing about, so we assume it's from
-- another package, where we aren't doing
redundant_source_import
= case (from, mod_info) of
- (ImportByUserSource, Just (_,False,_)) -> True
- other -> False
+ (ImportByUserSource, Just (_,False)) -> True
+ other -> False
in
- -- CHECK WHETHER WE HAVE IT ALREADY
- case mod_info of {
- Just (_, _, True)
- -> -- We're read it already so don't re-read it
- returnRn (ifaces, Nothing) ;
-
- _ ->
-- Issue a warning for a redundant {- SOURCE -} import
-- NB that we arrange to read all the ordinary imports before
Left err -> -- Not found, so add an empty export env to the Ifaces map
-- so that we don't look again
let
- new_mod_map = addToFM mod_map mod_name (False, False, True)
- new_ifaces = ifaces { iImpModInfo = new_mod_map }
+ fake_mod = mkVanillaModule mod_name
+ fake_iface = emptyModIface fake_mod
+ new_ifaces = ifaces { iPIT = extendModuleEnv pit fake_mod fake_iface }
in
setIfacesRn new_ifaces `thenRn_`
- returnRn (new_ifaces, Just err) ;
+ returnRn (fake_iface, Just err) ;
-- Found and parsed!
Right (mod, iface) ->
-- For an explicit user import, add to mod_map info about
-- the things the imported module depends on, extracted
- -- from its usage info.
+ -- from its usage info; and delete the module itself, which is now in the PIT
mod_map1 = case from of
- ImportByUser -> addModDeps mod (pi_usages iface) mod_map
+ ImportByUser -> addModDeps mod is_loaded (pi_usages iface) mod_map
other -> mod_map
- mod_map2 = addToFM mod_map1 mod_name (has_orphans, hi_boot_file, True)
+ mod_map2 = delFromFM mod_map1 mod_name
+ is_loaded m = maybeToBool (lookupIfaceByModName hit pit m)
-- Now add info about this module to the PIT
has_orphans = pi_orphan iface
- new_pit = extendModuleEnv (iPIT ifaces) mod mod_iface
+ new_pit = extendModuleEnv pit mod mod_iface
mod_iface = ModIface { mi_module = mod, mi_version = version,
- mi_exports = avails, mi_orphan = has_orphans,
+ mi_orphan = has_orphans, mi_boot = hi_boot_file,
+ mi_exports = avails,
mi_fixities = fix_env, mi_deprecs = deprec_env,
mi_usages = [], -- Will be filled in later
mi_decls = panic "No mi_decls in PIT",
iImpModInfo = mod_map2 }
in
setIfacesRn new_ifaces `thenRn_`
- returnRn (new_ifaces, Nothing)
- }}}
+ returnRn (mod_iface, Nothing)
+ }}
-----------------------------------------------------
-- Adding module dependencies from the
-- import decls in the interface file
-----------------------------------------------------
-addModDeps :: Module -> [ImportVersion a]
+addModDeps :: Module
+ -> (ModuleName -> Bool) -- True for module interfaces
+ -> [ImportVersion a]
-> ImportedModuleInfo -> ImportedModuleInfo
-- (addModDeps M ivs deps)
-- We are importing module M, and M.hi contains 'import' decls given by ivs
-addModDeps mod new_deps mod_deps
+addModDeps mod is_loaded new_deps mod_deps
= foldr add mod_deps filtered_new_deps
where
-- Don't record dependencies when importing a module from another package
-- Except for its descendents which contain orphans,
-- and in that case, forget about the boot indicator
- filtered_new_deps :: [(ModuleName, (WhetherHasOrphans, IsBootInterface, IsLoaded))]
+ filtered_new_deps :: [(ModuleName, (WhetherHasOrphans, IsBootInterface))]
filtered_new_deps
| isModuleInThisPackage mod
- = [ (imp_mod, (has_orphans, is_boot, False))
- | (imp_mod, has_orphans, is_boot, _) <- new_deps
+ = [ (imp_mod, (has_orphans, is_boot))
+ | (imp_mod, has_orphans, is_boot, _) <- new_deps,
+ not (is_loaded imp_mod)
]
- | otherwise = [ (imp_mod, (True, False, False))
- | (imp_mod, has_orphans, _, _) <- new_deps,
- has_orphans
+ | otherwise = [ (imp_mod, (True, False))
+ | (imp_mod, has_orphans, _, _) <- new_deps,
+ not (is_loaded imp_mod) && has_orphans
]
add (imp_mod, dep) deps = addToFM_C combine deps imp_mod dep
- combine old@(_, old_is_boot, old_is_loaded) new
- | old_is_loaded || not old_is_boot = old -- Keep the old info if it's already loaded
- -- or if it's a non-boot pending load
- | otherwise = new -- Otherwise pick new info
-
+ combine old@(old_has_orphans, old_is_boot) new@(new_has_orphans, new_is_boot)
+ | old_is_boot = new -- Record the best is_boot info
+ | otherwise = old
-----------------------------------------------------
-- 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
-- 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
-
load_entity mod (Avail occ)
- = new_name mod occ `thenRn` \ name ->
+ = newGlobalName mod occ `thenRn` \ name ->
returnRn (Avail name)
load_entity mod (AvailTC occ occs)
- = new_name mod occ `thenRn` \ name ->
- mapRn (new_name mod) occs `thenRn` \ names ->
+ = newGlobalName mod occ `thenRn` \ name ->
+ mapRn (newGlobalName mod) occs `thenRn` \ names ->
returnRn (AvailTC name names)
-> (Version, RdrNameTyClDecl)
-> RnM d (NameEnv Version, DeclsMap)
loadDecl mod (version_map, decls_map) (version, decl)
- = getIfaceDeclBinders new_name decl `thenRn` \ full_avail ->
+ = getIfaceDeclBinders mod decl `thenRn` \ full_avail ->
let
main_name = availName full_avail
new_decls_map = extendNameEnvList decls_map stuff
new_version_map = extendNameEnv version_map main_name version
in
returnRn (new_version_map, new_decls_map)
- where
- -- newTopBinder puts into the cache the binder with the
- -- module information set correctly. When the decl is later renamed,
- -- the binding site will thereby get the correct module.
- -- There maybe occurrences that don't have the correct Module, but
- -- by the typechecker will propagate the binding definition to all
- -- the occurrences, so that doesn't matter
- new_name rdr_name loc = newTopBinder mod rdr_name loc
-
-----------------------------------------------------
-- Loading fixity decls
loadDeprec deprec_env (n, txt)
= lookupOrigName n `thenRn` \ name ->
traceRn (text "Loaded deprecation(s) for" <+> ppr name <> colon <+> ppr txt) `thenRn_`
- returnRn (extendNameEnv deprec_env name txt)
+ returnRn (extendNameEnv deprec_env name (name,txt))
\end{code}
\begin{code}
getIfaceDeclBinders, getTyClDeclBinders
- :: (RdrName -> SrcLoc -> RnM d Name) -- New-name function
+ :: Module
-> RdrNameTyClDecl
-> RnM d AvailInfo
-getIfaceDeclBinders new_name tycl_decl
- = getTyClDeclBinders new_name tycl_decl `thenRn` \ avail ->
- getSysTyClDeclBinders new_name tycl_decl `thenRn` \ extras ->
+getIfaceDeclBinders mod tycl_decl
+ = getTyClDeclBinders mod tycl_decl `thenRn` \ avail ->
+ getSysTyClDeclBinders mod tycl_decl `thenRn` \ extras ->
returnRn (addSysAvails avail extras)
-- Add the sys-binders to avail. When we import the decl,
-- it's full_avail that will get added to the 'already-slurped' set (iSlurp)
-- If we miss out sys-binders, we'll read the decl multiple times!
-getTyClDeclBinders new_name (IfaceSig var ty prags src_loc)
- = new_name var src_loc `thenRn` \ var_name ->
+getTyClDeclBinders mod (IfaceSig var ty prags src_loc)
+ = newTopBinder mod var src_loc `thenRn` \ var_name ->
returnRn (Avail var_name)
-getTyClDeclBinders new_name tycl_decl
+getTyClDeclBinders mod tycl_decl
= mapRn do_one (tyClDeclNames tycl_decl) `thenRn` \ (main_name:sub_names) ->
returnRn (AvailTC main_name (main_name : sub_names))
where
- do_one (name,loc) = new_name name loc
+ do_one (name,loc) = newTopBinder mod name loc
\end{code}
@getDeclSysBinders@ gets the implicit binders introduced by a decl.
bindings of their own elsewhere.
\begin{code}
-getSysTyClDeclBinders new_name (ClassDecl _ cname _ _ sigs _ names src_loc)
- = sequenceRn [new_name n src_loc | n <- names]
+getSysTyClDeclBinders mod (ClassDecl _ cname _ _ sigs _ names src_loc)
+ = sequenceRn [newTopBinder mod n src_loc | n <- names]
-getSysTyClDeclBinders new_name (TyData _ _ _ _ cons _ _ _ _ _)
- = sequenceRn [new_name wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons]
+getSysTyClDeclBinders mod (TyData _ _ _ _ cons _ _ _ _ _)
+ = sequenceRn [newTopBinder mod wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons]
-getSysTyClDeclBinders new_name other_decl
+getSysTyClDeclBinders mod other_decl
= returnRn []
\end{code}
-
-
%*********************************************************
%* *
\subsection{Reading an interface file}
findAndReadIface doc_str mod_name hi_boot_file
= traceRn trace_msg `thenRn_`
-
- getFinderRn `thenRn` \ finder ->
- ioToRnM (finder mod_name) `thenRn` \ maybe_found ->
-
+ ioToRnM (findModule mod_name) `thenRn` \ maybe_found ->
+ doptRn Opt_D_dump_rn_trace `thenRn` \ rn_trace ->
case maybe_found of
- Right (Just (mod,locn))
- | hi_boot_file -> readIface mod (hi_file locn ++ "-hi-boot")
- | otherwise -> readIface mod (hi_file locn)
-
+ Right (Just (wanted_mod,locn))
+ -> ioToRnM_no_fail (
+ readIface rn_trace
+ (unJust (ml_hi_file locn) "findAndReadIface"
+ ++ if hi_boot_file then "-boot" else "")
+ )
+ `thenRn` \ read_result ->
+ case read_result of
+ Left bad -> returnRn (Left bad)
+ Right iface
+ -> let read_mod = pi_mod iface
+ in warnCheckRn (wanted_mod == read_mod)
+ (hiModuleNameMismatchWarn wanted_mod read_mod)
+ `thenRn_`
+ returnRn (Right (wanted_mod, iface))
-- Can't find it
other -> traceRn (ptext SLIT("...not found")) `thenRn_`
returnRn (Left (noIfaceErr mod_name hi_boot_file))
@readIface@ tries just the one file.
\begin{code}
-readIface :: Module -> String -> RnM d (Either Message (Module, ParsedIface))
+readIface :: Bool -> String -> IO (Either Message ParsedIface)
-- Nothing <=> file not found, or unreadable, or illegible
-- Just x <=> successfully found and parsed
-readIface wanted_mod file_path
- = traceRn (ptext SLIT("...reading from") <+> text file_path) `thenRn_`
- ioToRnM (hGetStringBuffer False file_path) `thenRn` \ read_result ->
- case read_result of
- Right contents ->
- case parseIface contents
+readIface tr file_path
+ = when tr (printErrs (ptext SLIT("readIFace") <+> text file_path))
+ >>
+ ((hGetStringBuffer False file_path >>= \ contents ->
+ case parseIface contents
PState{ bol = 0#, atbol = 1#,
context = [],
glasgow_exts = 1#,
loc = mkSrcLoc (mkFastString file_path) 1 } of
- POk _ (PIface iface) ->
- warnCheckRn (wanted_mod == read_mod)
- (hiModuleNameMismatchWarn wanted_mod read_mod) `thenRn_`
- returnRn (Right (wanted_mod, iface))
- where
- read_mod = pi_mod iface
-
+ POk _ (PIface iface) -> return (Right iface)
PFailed err -> bale_out err
parse_result -> bale_out empty
-- This last case can happen if the interface file is (say) empty
-- in which case the parser thinks it looks like an IdInfo or
-- something like that. Just an artefact of the fact that the
-- parser is used for several purposes at once.
-
- Left io_err -> bale_out (text (show io_err))
+ )
+ `catch`
+ (\ io_err -> bale_out (text (show io_err))))
where
- bale_out err = returnRn (Left (badIfaceFile file_path err))
+ bale_out err = return (Left (badIfaceFile file_path err))
\end{code}
%* *
%*********************************************************
-This has to be in RnIfaces (or RnHiFiles) because it calls loadHomeInterface
+@lookupFixityRn@ has to be in RnIfaces (or RnHiFiles) because
+it calls @loadHomeInterface@.
+
+lookupFixity is a bit strange.
+
+* Nested local fixity decls are put in the local fixity env, which we
+ find with getFixtyEnv
+
+* Imported fixities are found in the HIT or PIT
+
+* Top-level fixity decls in this module may be for Names that are
+ either Global (constructors, class operations)
+ or Local/Exported (everything else)
+ (See notes with RnNames.getLocalDeclBinders for why we have this split.)
+ We put them all in the local fixity environment
\begin{code}
lookupFixityRn :: Name -> RnMS Fixity
lookupFixityRn name
- | isLocallyDefined name
- = getFixityEnv `thenRn` \ local_fix_env ->
- returnRn (lookupLocalFixity local_fix_env name)
+ = getModuleRn `thenRn` \ this_mod ->
+ if nameIsLocalOrFrom this_mod name
+ then -- It's defined in this module
+ getFixityEnv `thenRn` \ local_fix_env ->
+ returnRn (lookupLocalFixity local_fix_env name)
- | otherwise -- Imported
+ else -- It's imported
-- For imported names, we have to get their fixities by doing a loadHomeInterface,
-- and consulting the Ifaces that comes back from that, because the interface
-- file for the Name might not have been loaded yet. Why not? Suppose you import module A,
-- right away (after all, it's possible that nothing from B will be used).
-- When we come across a use of 'f', we need to know its fixity, and it's then,
-- and only then, that we load B.hi. That is what's happening here.
- = getHomeIfaceTableRn `thenRn` \ hit ->
- loadHomeInterface doc name `thenRn` \ ifaces ->
- case lookupTable hit (iPIT ifaces) name of
- Just iface -> returnRn (lookupNameEnv (mi_fixities iface) name `orElse` defaultFixity)
- Nothing -> returnRn defaultFixity
+ loadHomeInterface doc name `thenRn` \ iface ->
+ returnRn (lookupNameEnv (mi_fixities iface) name `orElse` defaultFixity)
where
- doc = ptext SLIT("Checking fixity for") <+> ppr name
+ doc = ptext SLIT("Checking fixity for") <+> ppr name
\end{code}
projects / ghc-hetmet.git / blobdiff