\begin{code}
module RnHiFiles (
- findAndReadIface, loadInterface, loadHomeInterface,
+ readIface, findAndReadIface, loadInterface, loadHomeInterface,
tryLoadInterface, loadOrphanModules,
loadExports, loadFixDecls, loadDeprecs,
#include "HsVersions.h"
+import DriverUtil ( splitFilename )
import CmdLineOpts ( opt_IgnoreIfacePragmas )
-import HscTypes
-import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..),
- HsType(..), ConDecl(..),
- FixitySig(..), RuleDecl(..),
- tyClDeclNames
+import HscTypes ( ModuleLocation(..),
+ ModIface(..), emptyModIface,
+ VersionInfo(..), ImportedModuleInfo,
+ lookupIfaceByModName,
+ ImportVersion, WhetherHasOrphans, IsBootInterface,
+ DeclsMap, GatedDecl, IfaceInsts, IfaceRules,
+ AvailInfo, GenAvailInfo(..), Avails, Deprecations(..)
+ )
+import HsSyn ( TyClDecl(..), InstDecl(..),
+ HsType(..), FixitySig(..), RuleDecl(..),
+ tyClDeclNames, tyClDeclSysNames
)
import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl,
extractHsTyRdrNames
)
-import BasicTypes ( Version )
+import BasicTypes ( Version, defaultFixity )
import RnEnv
import RnMonad
-import ParseIface ( parseIface, IfaceStuff(..) )
+import ParseIface ( parseIface )
-import Name ( Name {-instance NamedThing-}, nameOccName,
- nameModule,
- NamedThing(..),
- mkNameEnv, extendNameEnv
+import Name ( Name {-instance NamedThing-},
+ nameModule, isLocalName, nameIsLocalOrFrom
)
-import Module ( Module,
- moduleName, isModuleInThisPackage,
+import NameEnv
+import Module ( Module,
+ moduleName, isHomeModule,
ModuleName, WhereFrom(..),
- extendModuleEnv, lookupModuleEnvByName,
+ extendModuleEnv, mkVanillaModule
)
-import RdrName ( RdrName, rdrNameOcc )
-import NameSet
-import SrcLoc ( mkSrcLoc, SrcLoc )
-import Maybes ( maybeToBool )
+import RdrName ( rdrNameOcc )
+import SrcLoc ( mkSrcLoc )
+import Maybes ( maybeToBool, orElse )
import StringBuffer ( hGetStringBuffer )
import FastString ( mkFastString )
import ErrUtils ( Message )
+import Finder ( findModule )
import Lex
import FiniteMap
import Outputable
import Bag
+import Config
+
+import Directory
\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)
+ Just err -> failWithRn ifaces (elaborate err)
+ where
+ elaborate err = hang (ptext SLIT("failed to load interface for") <+> quotes (ppr mod) <> colon)
+ 4 err
+
+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 ->
-
- -- 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 ->
+ getModuleRn `thenRn` \ this_mod ->
+ getIfacesRn `thenRn` \ ifaces@(Ifaces { iPIT = pit }) ->
+
+ -- CHECK WHETHER WE HAVE IT ALREADY
+ case lookupIfaceByModName hit pit mod_name of {
+ Just iface | case from of
+ ImportByUser -> not (mi_boot iface)
+ ImportByUserSource -> mi_boot iface
+ ImportBySystem -> True
+ ImportByCmdLine -> True
+ -> returnRn (iface, Nothing) ; -- Already loaded
+ -- The not (mi_boot iface) test checks that the already-loaded
+ -- interface isn't a boot iface. This can conceivably happen,
+ -- if the version checking happened to load a boot interface
+ -- before we got to real imports.
+ other ->
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
+ (ImportByCmdLine, _) -> False
+ (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
- 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) ;
+ (ImportByUserSource, Just (_,False)) -> True
+ other -> False
- _ ->
+ home_allowed | ImportByCmdLine <- from = True
+ | otherwise = False
+ in
-- Issue a warning for a redundant {- SOURCE -} import
-- NB that we arrange to read all the ordinary imports before
warnCheckRn (not redundant_source_import)
(warnRedundantSourceImport mod_name) `thenRn_`
+ -- Check that we aren't importing ourselves.
+ -- That only happens in Rename.checkOldIface,
+ -- which doesn't call tryLoadInterface
+ warnCheckRn
+ (not (isHomeModule this_mod) || moduleName this_mod /= mod_name)
+ (warnSelfImport this_mod) `thenRn_`
+
-- READ THE MODULE IN
- findAndReadIface doc_str mod_name hi_boot_file `thenRn` \ read_result ->
+ findAndReadIface doc_str mod_name hi_boot_file home_allowed
+ `thenRn` \ read_result ->
case read_result of {
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) ->
-- about, it should be from a different package to this one
WARN( not (maybeToBool mod_info) &&
case from of { ImportBySystem -> True; other -> False } &&
- isModuleInThisPackage mod,
+ isHomeModule mod,
ppr mod )
loadDecls mod (iDecls ifaces) (pi_decls iface) `thenRn` \ (decls_vers, new_decls) ->
loadRules mod (iRules ifaces) (pi_rules iface) `thenRn` \ (rule_vers, new_rules) ->
- foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts ->
+ loadInstDecls mod (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts ->
loadExports (pi_exports iface) `thenRn` \ (export_vers, avails) ->
loadFixDecls mod (pi_fixity iface) `thenRn` \ fix_env ->
loadDeprecs mod (pi_deprecs iface) `thenRn` \ deprec_env ->
-- 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
+
+ this_mod_name = moduleName this_mod
+ is_loaded m = m == this_mod_name
+ || maybeToBool (lookupIfaceByModName hit pit m)
+ -- We treat the currently-being-compiled module as 'loaded' because
+ -- even though it isn't yet in the HIT or PIT; otherwise it gets
+ -- put into iImpModInfo, and then spat out into its own interface
+ -- file as a dependency
-- 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",
- mi_globals = panic "No mi_globals in PIT"
+ mi_globals = mkIfaceGlobalRdrEnv avails
}
new_ifaces = ifaces { iPIT = new_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 modules that are already loaded
+ -> [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
+ | isHomeModule mod = [ (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)
-
-
-loadExport :: Module -> ExportItem -> RnM d [AvailInfo]
-loadExport this_mod (mod, entities)
- | mod == moduleName this_mod = returnRn []
- -- 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
- -- filter them out up front. This situation only arises if a module
- -- imports itself, or another module that imported it. (Necessarily,
- -- this invoves a loop.) Consequence: if you say
- -- module A where
- -- import B( AType )
- -- type AType = ...
- --
- -- module B( AType ) where
- -- import {-# SOURCE #-} A( AType )
- --
- -- then you'll get a 'B does not export AType' message. A bit bogus
- -- but it's a bogus thing to do!
+ = mapRn loadExport items `thenRn` \ avails_s ->
+ returnRn (vers, avails_s)
- | otherwise
- = mapRn (load_entity mod) entities
- where
- new_name mod occ = newGlobalName mod occ
+loadExport :: ExportItem -> RnM d (ModuleName, Avails)
+loadExport (mod, entities)
+ = mapRn (load_entity mod) entities `thenRn` \ avails ->
+ returnRn (mod, avails)
+ where
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)
-> DeclsMap
-> [(Version, RdrNameTyClDecl)]
-> RnM d (NameEnv Version, DeclsMap)
-loadDecls mod decls_map decls
- = foldlRn (loadDecl mod) (emptyNameEnv, decls_map) decls
+loadDecls mod (decls_map, n_slurped) decls
+ = foldlRn (loadDecl mod) (emptyNameEnv, decls_map) decls `thenRn` \ (vers, decls_map') ->
+ returnRn (vers, (decls_map', n_slurped))
-loadDecl :: Module
- -> (NameEnv Version, DeclsMap)
- -> (Version, RdrNameTyClDecl)
- -> RnM d (NameEnv Version, DeclsMap)
loadDecl mod (version_map, decls_map) (version, decl)
- = getIfaceDeclBinders new_name decl `thenRn` \ full_avail ->
+ = getTyClDeclBinders mod decl `thenRn` \ (avail, sys_names) ->
let
+ full_avail = case avail of
+ Avail n -> avail
+ AvailTC n ns -> AvailTC n (sys_names ++ ns)
main_name = availName full_avail
new_decls_map = extendNameEnvList decls_map stuff
stuff = [ (name, (full_avail, name==main_name, (mod, decl)))
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
-- Loading instance decls
-----------------------------------------------------
-loadInstDecl :: Module
- -> IfaceInsts
- -> RdrNameInstDecl
- -> RnM d IfaceInsts
-loadInstDecl mod insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc)
- =
- -- Find out what type constructors and classes are "gates" for the
+loadInstDecls :: Module
+ -> IfaceInsts
+ -> [RdrNameInstDecl]
+ -> RnM d IfaceInsts
+loadInstDecls mod (insts, n_slurped) decls
+ = setModuleRn mod $
+ foldlRn (loadInstDecl mod) insts decls `thenRn` \ insts' ->
+ returnRn (insts', n_slurped)
+
+
+loadInstDecl mod insts decl@(InstDecl inst_ty _ _ _ _)
+ = -- Find out what type constructors and classes are "gates" for the
-- instance declaration. If all these "gates" are slurped in then
-- we should slurp the instance decl too.
--
munged_inst_ty = removeContext inst_ty
free_names = extractHsTyRdrNames munged_inst_ty
in
- setModuleRn mod $
- mapRn lookupOrigName free_names `thenRn` \ gate_names ->
- returnRn ((mkNameSet gate_names, (mod, InstD decl)) `consBag` insts)
+ mapRn lookupIfaceName free_names `thenRn` \ gate_names ->
+ returnRn ((gate_names, (mod, decl)) `consBag` insts)
-- In interface files, the instance decls now look like
loadRules :: Module -> IfaceRules
-> (Version, [RdrNameRuleDecl])
-> RnM d (Version, IfaceRules)
-loadRules mod rule_bag (version, rules)
+loadRules mod (rule_bag, n_slurped) (version, rules)
| null rules || opt_IgnoreIfacePragmas
- = returnRn (version, rule_bag)
+ = returnRn (version, (rule_bag, n_slurped))
| otherwise
= setModuleRn mod $
mapRn (loadRule mod) rules `thenRn` \ new_rules ->
- returnRn (version, rule_bag `unionBags` listToBag new_rules)
+ returnRn (version, (rule_bag `unionBags` listToBag new_rules, n_slurped))
-loadRule :: Module -> RdrNameRuleDecl -> RnM d GatedDecl
+loadRule :: Module -> RdrNameRuleDecl -> RnM d (GatedDecl RdrNameRuleDecl)
-- "Gate" the rule simply by whether the rule variable is
-- needed. We can refine this later.
loadRule mod decl@(IfaceRule _ _ var _ _ src_loc)
- = lookupOrigName var `thenRn` \ var_name ->
- returnRn (unitNameSet var_name, (mod, RuleD decl))
+ = lookupIfaceName var `thenRn` \ var_name ->
+ returnRn ([var_name], (mod, decl))
-----------------------------------------------------
foldlRn loadDeprec emptyNameEnv prs `thenRn` \ env ->
returnRn (DeprecSome env)
loadDeprec deprec_env (n, txt)
- = lookupOrigName n `thenRn` \ name ->
+ = lookupIfaceName 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}
It doesn't deal with source-code specific things: @ValD@, @DefD@. They
are handled by the sourc-code specific stuff in @RnNames@.
-\begin{code}
-getIfaceDeclBinders, getTyClDeclBinders
- :: (RdrName -> SrcLoc -> RnM d Name) -- New-name function
- -> RdrNameTyClDecl
- -> RnM d AvailInfo
-
-getIfaceDeclBinders new_name tycl_decl
- = getTyClDeclBinders new_name tycl_decl `thenRn` \ avail ->
- getSysTyClDeclBinders new_name 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 ->
- returnRn (Avail var_name)
-
-getTyClDeclBinders new_name 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
-\end{code}
-
-@getDeclSysBinders@ gets the implicit binders introduced by a decl.
-A the moment that's just the tycon and datacon that come with a class decl.
-They aren't returned by @getDeclBinders@ because they aren't in scope;
-but they {\em should} be put into the @DeclsMap@ of this module.
+ *** See "THE NAMING STORY" in HsDecls ****
-Note that this excludes the default-method names of a class decl,
-and the dict fun of an instance decl, because both of these have
-bindings of their own elsewhere.
\begin{code}
-getSysTyClDeclBinders new_name (ClassDecl _ cname _ _ sigs _ names src_loc)
- = sequenceRn [new_name n src_loc | n <- names]
+getTyClDeclBinders
+ :: Module
+ -> RdrNameTyClDecl
+ -> RnM d (AvailInfo, [Name]) -- The [Name] are the system names
-getSysTyClDeclBinders new_name (TyData _ _ _ _ cons _ _ _ _ _)
- = sequenceRn [new_name wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons]
+-----------------
+getTyClDeclBinders mod (IfaceSig {tcdName = var, tcdLoc = src_loc})
+ = newTopBinder mod var src_loc `thenRn` \ var_name ->
+ returnRn (Avail var_name, [])
-getSysTyClDeclBinders new_name other_decl
- = returnRn []
-\end{code}
+getTyClDeclBinders mod tycl_decl
+ = new_top_bndrs mod (tyClDeclNames tycl_decl) `thenRn` \ names@(main_name:_) ->
+ new_top_bndrs mod (tyClDeclSysNames tycl_decl) `thenRn` \ sys_names ->
+ returnRn (AvailTC main_name names, sys_names)
+-----------------
+new_top_bndrs mod names_w_locs
+ = sequenceRn [newTopBinder mod name loc | (name,loc) <- names_w_locs]
+\end{code}
%*********************************************************
findAndReadIface :: SDoc -> ModuleName
-> IsBootInterface -- True <=> Look for a .hi-boot file
-- False <=> Look for .hi file
+ -> Bool -- True <=> can read home interface
-> RnM d (Either Message (Module, ParsedIface))
-- Nothing <=> file not found, or unreadable, or illegible
-- Just x <=> successfully found and parsed
-findAndReadIface doc_str mod_name hi_boot_file
+findAndReadIface doc_str mod_name hi_boot_file home_allowed
= traceRn trace_msg `thenRn_`
- getFinderRn `thenRn` \ finder ->
- ioToRnM (finder mod_name) `thenRn` \ maybe_found ->
-
+ ioToRnM (findModule mod_name) `thenRn` \ maybe_found ->
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))
+ -> -- in CmdLineMode, we cannot demand-load home interfaces
+ -- because the corresponding code won't be loaded, so we
+ -- check for this here and emit an error message.
+ if (home_allowed && isHomeModule wanted_mod)
+ then returnRn (Left (notLoaded wanted_mod))
+ else
+
+ mkHiPath hi_boot_file locn `thenRn` \ file ->
+ readIface file `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))
ptext SLIT("interface for"),
ppr mod_name <> semi],
nest 4 (ptext SLIT("reason:") <+> doc_str)]
+
+mkHiPath hi_boot_file locn
+ | hi_boot_file =
+ ioToRnM_no_fail (doesFileExist hi_boot_ver_path) `thenRn` \ b ->
+ if b then returnRn hi_boot_ver_path
+ else returnRn hi_boot_path
+ | otherwise = returnRn hi_path
+ where hi_path = ml_hi_file locn
+ (hi_base, _hi_suf) = splitFilename hi_path
+ hi_boot_path = hi_base ++ ".hi-boot"
+ hi_boot_ver_path = hi_base ++ ".hi-boot-" ++ cHscIfaceFileVersion
\end{code}
@readIface@ tries just the one file.
\begin{code}
-readIface :: Module -> String -> RnM d (Either Message (Module, ParsedIface))
+readIface :: String -> RnM d (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
- PState{ bol = 0#, atbol = 1#,
+readIface file_path
+ = --ioToRnM (putStrLn ("reading iface " ++ file_path)) `thenRn_`
+ traceRn (ptext SLIT("readIFace") <+> text file_path) `thenRn_`
+
+ ioToRnM (hGetStringBuffer False file_path) `thenRn` \ read_result ->
+ case read_result of {
+ Left io_error -> bale_out (text (show io_error)) ;
+ Right contents ->
+
+ case parseIface contents init_parser_state of
+ POk _ iface -> returnRn (Right iface)
+ PFailed err -> bale_out err
+ }
+ where
+ init_parser_state = 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
-
- 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))
- where
+ loc = mkSrcLoc (mkFastString file_path) 1 }
+
bale_out err = returnRn (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}
warnRedundantSourceImport mod_name
= ptext SLIT("Unnecessary {- SOURCE -} in the import of module")
<+> quotes (ppr mod_name)
+
+notLoaded mod
+ = ptext SLIT("Module") <+> quotes (ppr mod) <+> ptext SLIT("is not loaded")
+
+warnSelfImport mod
+ = ptext SLIT("Importing my own interface: module") <+> ppr mod
\end{code}
projects / ghc-hetmet.git / blobdiff