importDecl, recordSlurp,
getImportVersions, getSlurpedNames, getRnStats, getImportedFixities,
- checkUpToDate, loadHomeInterface,
+ checkUpToDate,
getDeclBinders,
mkSearchPath
import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), IfaceSig(..),
HsType(..), ConDecl(..), IE(..), ConDetails(..), Sig(..),
FixitySig(..),
- hsDeclName, countTyClDecls, isDataDecl
+ hsDeclName, countTyClDecls, isDataDecl, isClassOpSig
)
-import BasicTypes ( Version, NewOrData(..), IfaceFlavour(..) )
+import BasicTypes ( Version, NewOrData(..) )
import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl, RdrNameTyClDecl,
- RdrName(..), rdrNameOcc
)
-import RnEnv ( newImportedGlobalName, addImplicitOccsRn, pprAvail,
- availName, availNames, addAvailToNameSet, ifaceFlavour
+import RnEnv ( newImportedGlobalName, newImportedGlobalFromRdrName,
+ addImplicitOccsRn, pprAvail,
+ availName, availNames, addAvailToNameSet
)
import RnSource ( rnHsSigType )
import RnMonad
lookupFM, addToFM, addToFM_C, addListToFM,
fmToList
)
-import Name ( Name {-instance NamedThing-}, OccName,
- nameModule, moduleString, pprModule, isLocallyDefined,
- isWiredInName, maybeWiredInTyConName, pprModule,
- maybeWiredInIdName, nameUnique, NamedThing(..)
+import Name ( Name {-instance NamedThing-},
+ nameModule, isLocallyDefined,
+ isWiredInName, maybeWiredInTyConName,
+ maybeWiredInIdName, nameUnique, NamedThing(..),
+ pprEncodedFS
)
+import Module ( Module, mkBootModule, moduleString, pprModule,
+ mkDynamicModule, moduleIfaceFlavour, bootFlavour, hiFile,
+ moduleUserString, moduleFS, setModuleFlavour
+ )
+import RdrName ( RdrName, rdrNameOcc )
import NameSet
import Id ( idType, isDataConId_maybe )
import DataCon ( dataConTyCon, dataConType )
import IO ( isDoesNotExistError )
import List ( nub )
-
\end{code}
%*********************************************************
\begin{code}
-loadHomeInterface :: SDoc -> Name -> RnMG Ifaces
+loadHomeInterface :: SDoc -> Name -> RnMG (Module, Ifaces)
loadHomeInterface doc_str name
- = loadInterface doc_str (nameModule name) (ifaceFlavour name)
+ = loadInterface doc_str (nameModule name)
-loadInterface :: SDoc -> Module -> IfaceFlavour -> RnMG Ifaces
-loadInterface doc_str load_mod as_source
+loadInterface :: SDoc -> Module -> RnMG (Module, Ifaces)
+loadInterface doc_str load_mod
= getIfacesRn `thenRn` \ ifaces ->
let
- this_mod = iMod ifaces
+ hi_boot_wanted = bootFlavour (moduleIfaceFlavour load_mod)
mod_map = iModMap ifaces
(insts, tycls_names) = iDefInsts ifaces
+
in
-- CHECK WHETHER WE HAVE IT ALREADY
case lookupFM mod_map load_mod of {
- Just (hif, _, _) | hif `as_good_as` as_source
- -> -- Already in the cache; don't re-read it
- returnRn ifaces ;
+ Just (existing_hif, _, _)
+ | hi_boot_wanted || not (bootFlavour existing_hif)
+ -> -- Already in the cache, and new version is no better than old,
+ -- so don't re-read it
+ returnRn (setModuleFlavour existing_hif load_mod, ifaces) ;
other ->
-- READ THE MODULE IN
- findAndReadIface doc_str load_mod as_source `thenRn` \ read_result ->
+ findAndReadIface doc_str load_mod `thenRn` \ read_result ->
case read_result of {
- -- Check for not found
- Nothing -> -- Not found, so add an empty export env to the Ifaces map
+ Nothing | not hi_boot_wanted && load_mod `elem` thinAirModules
+ -> -- Hack alert! When compiling PrelBase we have to load the
+ -- decls for packCString# and friends; they are 'thin-air' Ids
+ -- (see PrelInfo.lhs). So if we don't find the HiFile we quietly
+ -- look for a .hi-boot file instead, and use that
+ --
+ -- NB this causes multiple "failed" attempts to read PrelPack,
+ -- which makes curious reading with -dshow-rn-trace, but
+ -- there's no harm done
+ loadInterface doc_str (mkBootModule load_mod)
+
+
+ | otherwise
+ -> -- 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 load_mod (HiFile, 0, [])
+ new_mod_map = addToFM mod_map load_mod (hiFile, 0, [])
new_ifaces = ifaces { iModMap = new_mod_map }
in
setIfacesRn new_ifaces `thenRn_`
- failWithRn new_ifaces (noIfaceErr load_mod) ;
+ failWithRn (load_mod, new_ifaces) (noIfaceErr load_mod) ;
-- Found and parsed!
- Just (ParsedIface _ mod_vers usages exports rd_inst_mods rd_decls rd_insts) ->
+ Just (the_mod, ParsedIface mod_vers usages exports rd_inst_mods rd_decls rd_insts) ->
+
-- LOAD IT INTO Ifaces
+ -- First set the module
+
-- NB: *first* we do loadDecl, so that the provenance of all the locally-defined
--- names is done correctly (notably, whether this is an .hi file or .hi-boot file).
-- If we do loadExport first the wrong info gets into the cache (unless we
-- explicitly tag each export which seems a bit of a bore)
- foldlRn (loadDecl load_mod as_source)
- (iDecls ifaces) rd_decls `thenRn` \ new_decls ->
- foldlRn (loadFixDecl load_mod as_source)
- (iFixes ifaces) rd_decls `thenRn` \ new_fixities ->
- mapRn loadExport exports `thenRn` \ avails_s ->
- foldlRn (loadInstDecl load_mod) insts rd_insts `thenRn` \ new_insts ->
+
+ getModuleRn `thenRn` \ this_mod ->
+ setModuleRn the_mod $ -- First set the module name of the module being loaded,
+ -- so that unqualified occurrences in the interface file
+ -- get the right qualifer
+ foldlRn loadDecl (iDecls ifaces) rd_decls `thenRn` \ new_decls ->
+ foldlRn loadFixDecl (iFixes ifaces) rd_decls `thenRn` \ new_fixities ->
+ foldlRn loadInstDecl insts rd_insts `thenRn` \ new_insts ->
+
+ mapRn (loadExport this_mod) exports `thenRn` \ avails_s ->
let
- mod_details = (as_source, mod_vers, concat avails_s)
+ -- Notice: the 'flavour' of the loaded Module does not have to
+ -- be the same as the requested Module.
+ the_mod_hif = moduleIfaceFlavour the_mod
+ mod_details = (the_mod_hif, mod_vers, concat avails_s)
-- Exclude this module from the "special-inst" modules
new_inst_mods = iInstMods ifaces `unionLists` (filter (/= this_mod) rd_inst_mods)
- new_ifaces = ifaces { iModMap = addToFM mod_map load_mod mod_details,
+ new_ifaces = ifaces { iModMap = addToFM mod_map the_mod mod_details,
iDecls = new_decls,
iFixes = new_fixities,
iDefInsts = (new_insts, tycls_names),
iInstMods = new_inst_mods }
in
setIfacesRn new_ifaces `thenRn_`
- returnRn new_ifaces
+ returnRn (the_mod, new_ifaces)
}}
-as_good_as HiFile any = True
-as_good_as any HiBootFile = True
-as_good_as _ _ = False
-
+loadExport :: Module -> ExportItem -> RnMG [AvailInfo]
+loadExport this_mod (mod, entities)
+ | mod == 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!
-loadExport :: ExportItem -> RnMG [AvailInfo]
-loadExport (mod, hif, entities)
- = mapRn load_entity entities
+ | otherwise
+ = setModuleFlavourRn mod `thenRn` \ mod' ->
+ mapRn (load_entity mod') entities
where
- new_name occ = newImportedGlobalName mod occ hif
+ new_name mod occ = newImportedGlobalName mod occ
- load_entity (Avail occ)
- = new_name occ `thenRn` \ name ->
+ load_entity mod (Avail occ)
+ = new_name mod occ `thenRn` \ name ->
returnRn (Avail name)
- load_entity (AvailTC occ occs)
- = new_name occ `thenRn` \ name ->
- mapRn new_name occs `thenRn` \ names ->
+ load_entity mod (AvailTC occ occs)
+ = new_name mod occ `thenRn` \ name ->
+ mapRn (new_name mod) occs `thenRn` \ names ->
returnRn (AvailTC name names)
-loadFixDecl :: Module -> IfaceFlavour -> FixityEnv
+loadFixDecl :: FixityEnv
-> (Version, RdrNameHsDecl)
-> RnMG FixityEnv
-loadFixDecl mod as_source fixity_env (version, FixD (FixitySig rdr_name fixity loc))
+loadFixDecl fixity_env (version, FixD (FixitySig rdr_name fixity loc))
= -- Ignore the version; when the fixity changes the version of
-- its 'host' entity changes, so we don't need a separate version
-- number for fixities
- new_implicit_name mod as_source rdr_name `thenRn` \ name ->
+ newImportedGlobalFromRdrName rdr_name `thenRn` \ name ->
let
new_fixity_env = addToNameEnv fixity_env name (FixitySig name fixity loc)
in
returnRn new_fixity_env
-- Ignore the other sorts of decl
-loadFixDecl mod as_source fixity_env other_decl = returnRn fixity_env
+loadFixDecl fixity_env other_decl = returnRn fixity_env
-loadDecl :: Module -> IfaceFlavour -> DeclsMap
+loadDecl :: DeclsMap
-> (Version, RdrNameHsDecl)
-> RnMG DeclsMap
-loadDecl mod as_source decls_map (version, decl)
- = getDeclBinders new_name decl `thenRn` \ avail ->
+loadDecl decls_map (version, decl)
+ = getDeclBinders new_name decl `thenRn` \ maybe_avail ->
+ case maybe_avail of {
+ Nothing -> returnRn decls_map; -- No bindings
+ Just avail ->
+
getDeclSysBinders new_name decl `thenRn` \ sys_bndrs ->
let
main_name = availName avail
addToNameEnv decls_map name stuff
in
returnRn new_decls_map
+ }
where
- new_name rdr_name loc = new_implicit_name mod as_source rdr_name
+ new_name rdr_name loc = newImportedGlobalFromRdrName rdr_name
{-
If a signature decl is being loaded, and optIgnoreIfacePragmas is on,
we toss away unfolding information.
its interface file. Hence, B is recompiled, maybe changing its interface file,
which will the unfolding info used in A to become invalid. Simple way out is to
just ignore unfolding info.
+
+ [Jan 99: I junked the second test above. If we're importing from an hi-boot
+ file there isn't going to *be* any pragma info. Maybe the above comment
+ dates from a time where we picked up a .hi file first if it existed?]
-}
decl' =
case decl of
- SigD (IfaceSig name tp ls loc) | from_hi_boot || opt_IgnoreIfacePragmas ->
+ SigD (IfaceSig name tp ls loc) | opt_IgnoreIfacePragmas ->
SigD (IfaceSig name tp [] loc)
_ -> decl
- from_hi_boot = case as_source of
- HiBootFile -> True
- other -> False
-
-new_implicit_name mod as_source rdr_name
- = newImportedGlobalName mod (rdrNameOcc rdr_name) as_source
-
-loadInstDecl :: Module
- -> Bag IfaceInst
+loadInstDecl :: Bag IfaceInst
-> RdrNameInstDecl
-> RnMG (Bag IfaceInst)
-loadInstDecl mod_name insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc)
+loadInstDecl insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc)
=
-- Find out what type constructors and classes are "gates" for the
-- instance declaration. If all these "gates" are slurped in then
in
-- We find the gates by renaming the instance type with in a
-- and returning the free variables of the type
- initRnMS emptyRnEnv mod_name vanillaInterfaceMode (
+ initRnMS emptyRnEnv vanillaInterfaceMode (
discardOccurrencesRn (rnHsSigType (text "an instance decl") munged_inst_ty)
) `thenRn` \ (_, gate_names) ->
+ getModuleRn `thenRn` \ mod_name ->
returnRn (((mod_name, decl), gate_names) `consBag` insts)
vanillaInterfaceMode = InterfaceMode Compulsory
\begin{code}
checkUpToDate :: Module -> RnMG Bool -- True <=> no need to recompile
checkUpToDate mod_name
- = findAndReadIface doc_str mod_name HiFile `thenRn` \ read_result ->
+ = findAndReadIface doc_str mod_name `thenRn` \ read_result ->
-- CHECK WHETHER WE HAVE IT ALREADY
case read_result of
pprModule mod_name]) `thenRn_`
returnRn False
- Just (ParsedIface _ _ usages _ _ _ _)
+ Just (_, ParsedIface _ usages _ _ _ _)
-> -- Found it, so now check it
checkModUsage usages
where
checkModUsage [] = returnRn True -- Yes! Everything is up to date!
-checkModUsage ((mod, hif, old_mod_vers, whats_imported) : rest)
- = loadInterface doc_str mod hif `thenRn` \ ifaces ->
+checkModUsage ((mod, old_mod_vers, whats_imported) : rest)
+ = loadInterface doc_str mod `thenRn` \ (mod, ifaces) ->
let
maybe_new_mod_vers = lookupFM (iModMap ifaces) mod
Just (_, new_mod_vers, _) = maybe_new_mod_vers
= returnRn True -- Yes! All up to date!
checkEntityUsage mod decls ((occ_name,old_vers) : rest)
- = newImportedGlobalName mod occ_name HiFile `thenRn` \ name ->
+ = newImportedGlobalName mod occ_name `thenRn` \ name ->
case lookupNameEnv decls name of
Nothing -> -- We used it before, but it ain't there now
%*********************************************************
\begin{code}
-importDecl :: Occurrence -> RnSMode -> RnMG (Maybe RdrNameHsDecl)
+importDecl :: Occurrence -> RnMode -> RnMG (Maybe RdrNameHsDecl)
-- Returns Nothing for a wired-in or already-slurped decl
importDecl (name, loc) mode
\end{code}
\begin{code}
-getNonWiredInDecl :: Name -> SrcLoc -> RnSMode -> RnMG (Maybe RdrNameHsDecl)
+getNonWiredInDecl :: Name -> SrcLoc -> RnMode -> RnMG (Maybe RdrNameHsDecl)
getNonWiredInDecl needed_name loc mode
= traceRn doc_str `thenRn_`
- loadHomeInterface doc_str needed_name `thenRn` \ ifaces ->
+ loadHomeInterface doc_str needed_name `thenRn` \ (_, ifaces) ->
case lookupNameEnv (iDecls ifaces) needed_name of
-- Special case for data/newtype type declarations
\begin{code}
getWiredInDecl name mode
- = initRnMS emptyRnEnv mod_name new_mode
- get_wired `thenRn` \ avail ->
+ = setModuleRn mod_name (
+ initRnMS emptyRnEnv new_mode get_wired
+ ) `thenRn` \ avail ->
recordSlurp Nothing necessity avail `thenRn_`
-- Force in the home module in case it has instance decls for
%*********************************************************
\begin{code}
-getInterfaceExports :: Module -> IfaceFlavour -> RnMG Avails
-getInterfaceExports mod as_source
- = loadInterface doc_str mod as_source `thenRn` \ ifaces ->
+getInterfaceExports :: Module -> RnMG (Module, Avails)
+getInterfaceExports mod
+ = loadInterface doc_str mod `thenRn` \ (mod, ifaces) ->
case lookupFM (iModMap ifaces) mod of
Nothing -> -- Not there; it must be that the interface file wasn't found;
-- the error will have been reported already.
-- (Actually loadInterface should put the empty export env in there
-- anyway, but this does no harm.)
- returnRn []
+ returnRn (mod, [])
- Just (_, _, avails) -> returnRn avails
+ Just (_, _, avails) -> returnRn (mod, avails)
where
doc_str = sep [pprModule mod, ptext SLIT("is directly imported")]
\end{code}
version
avail@(AvailTC tycon_name _)
ty_decl@(TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)
- | needed_name == tycon_name
- && opt_PruneTyDecls
+ | null condecls ||
+ -- HACK ALERT! If the data type is abstract then it must from a
+ -- hand-written hi-boot file. We put it in the deferred pile unconditionally,
+ -- because we don't want to read it in, and then later find a decl for a constructor
+ -- from that type, read the real interface file, and read in the full data type
+ -- decl again!!!
+
+ (needed_name == tycon_name
+ && opt_PruneTyDecls
-- don't prune newtypes, as the code generator may
-- want to peer inside a newtype type constructor
-- (ClosureInfo.fun_result_ty is the culprit.)
- && not (new_or_data == NewType)
- && not (nameUnique needed_name `elem` cCallishTyKeys)
+ && not (new_or_data == NewType)
+ && not (nameUnique needed_name `elem` cCallishTyKeys))
-- Hack! Don't prune these tycons whose constructors
-- the desugarer must be able to see when desugaring
-- a CCall. Ugh!
getImportedInstDecls
= -- First load any special-instance modules that aren't aready loaded
getSpecialInstModules `thenRn` \ inst_mods ->
- mapRn load_it inst_mods `thenRn_`
+ mapRn_ load_it inst_mods `thenRn_`
-- Now we're ready to grab the instance declarations
-- Find the un-gated ones and return them,
setIfacesRn new_ifaces `thenRn_`
returnRn un_gated_insts
where
- load_it mod = loadInterface (doc_str mod) mod HiFile
+ load_it mod = loadInterface (doc_str mod) mod
doc_str mod = sep [pprModule mod, ptext SLIT("is a special-instance module")]
= getIfacesRn `thenRn` \ ifaces ->
returnRn (iInstMods ifaces)
-getImportedFixities :: RnMG FixityEnv
-getImportedFixities
- = getIfacesRn `thenRn` \ ifaces ->
+getImportedFixities :: GlobalRdrEnv -> RnMG FixityEnv
+ -- Get all imported fixities
+ -- We first make sure that all the home modules
+ -- of all in-scope variables are loaded.
+getImportedFixities gbl_env
+ = let
+ home_modules = [ nameModule name | names <- rdrEnvElts gbl_env,
+ name <- names,
+ not (isLocallyDefined name)
+ ]
+ in
+ mapRn_ load (nub home_modules) `thenRn_`
+
+ -- Now we can snaffle the fixity env
+ getIfacesRn `thenRn` \ ifaces ->
returnRn (iFixes ifaces)
+ where
+ load mod = loadInterface doc_str mod
+ where
+ doc_str = ptext SLIT("Need fixities from") <+> ppr mod
\end{code}
mk_version_info (mod, local_versions)
= case lookupFM mod_map mod of
- Just (hif, version, _) -> (mod, hif, version, local_versions)
+ Just (hif, version, _) -> (mod, version, local_versions)
in
returnRn (map mk_version_info (fmToList mv_map))
where
\begin{code}
getDeclBinders :: (RdrName -> SrcLoc -> RnMG Name) -- New-name function
-> RdrNameHsDecl
- -> RnMG AvailInfo
+ -> RnMG (Maybe AvailInfo)
getDeclBinders new_name (TyClD (TyData _ _ tycon _ condecls _ _ src_loc))
= new_name tycon src_loc `thenRn` \ tycon_name ->
getConFieldNames new_name condecls `thenRn` \ sub_names ->
- returnRn (AvailTC tycon_name (tycon_name : nub sub_names))
+ returnRn (Just (AvailTC tycon_name (tycon_name : nub sub_names)))
-- The "nub" is because getConFieldNames can legitimately return duplicates,
-- when a record declaration has the same field in multiple constructors
getDeclBinders new_name (TyClD (TySynonym tycon _ _ src_loc))
= new_name tycon src_loc `thenRn` \ tycon_name ->
- returnRn (AvailTC tycon_name [tycon_name])
+ returnRn (Just (AvailTC tycon_name [tycon_name]))
getDeclBinders new_name (TyClD (ClassDecl _ cname _ sigs _ _ tname dname src_loc))
= new_name cname src_loc `thenRn` \ class_name ->
-- Record the names for the class ops
- mapRn (getClassOpNames new_name) sigs `thenRn` \ sub_names ->
+ let
+ -- just want class-op sigs
+ op_sigs = filter isClassOpSig sigs
+ in
+ mapRn (getClassOpNames new_name) op_sigs `thenRn` \ sub_names ->
- returnRn (AvailTC class_name (class_name : sub_names))
+ returnRn (Just (AvailTC class_name (class_name : sub_names)))
getDeclBinders new_name (SigD (IfaceSig var ty prags src_loc))
= new_name var src_loc `thenRn` \ var_name ->
- returnRn (Avail var_name)
+ returnRn (Just (Avail var_name))
-getDeclBinders new_name (FixD _) = returnRn NotAvailable
-getDeclBinders new_name (ForD _) = returnRn NotAvailable
-getDeclBinders new_name (DefD _) = returnRn NotAvailable
-getDeclBinders new_name (InstD _) = returnRn NotAvailable
+getDeclBinders new_name (FixD _) = returnRn Nothing
+getDeclBinders new_name (ForD _) = returnRn Nothing
+getDeclBinders new_name (DefD _) = returnRn Nothing
+getDeclBinders new_name (InstD _) = returnRn Nothing
----------------
getConFieldNames new_name (ConDecl con _ _ (RecCon fielddecls) src_loc : rest)
where
fields = concat (map fst fielddecls)
-getConFieldNames new_name (ConDecl con _ _ _ src_loc : rest)
+getConFieldNames new_name (ConDecl con _ _ condecl src_loc : rest)
= new_name con src_loc `thenRn` \ n ->
+ (case condecl of
+ NewCon _ (Just f) ->
+ new_name f src_loc `thenRn` \ new_f ->
+ returnRn [n,new_f]
+ _ -> returnRn [n]) `thenRn` \ nn ->
getConFieldNames new_name rest `thenRn` \ ns ->
- returnRn (n:ns)
+ returnRn (nn ++ ns)
getConFieldNames new_name [] = returnRn []
@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'te returned by getDeclBinders because they aren't in scope;
-but they should be put into the DeclsMap of this module.
+but they *should* be put into the DeclsMap of this module.
\begin{code}
getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ sigs _ _ tname dname src_loc))
%*********************************************************
\begin{code}
-findAndReadIface :: SDoc -> Module
- -> IfaceFlavour
- -> RnMG (Maybe ParsedIface)
+findAndReadIface :: SDoc -> Module -> RnMG (Maybe (Module, ParsedIface))
-- Nothing <=> file not found, or unreadable, or illegible
-- Just x <=> successfully found and parsed
-findAndReadIface doc_str mod_name as_source
+
+findAndReadIface doc_str mod_name
= traceRn trace_msg `thenRn_`
-- we keep two maps for interface files,
-- one for 'normal' ones, the other for .hi-boot files,
-- hence the need to signal which kind we're interested.
- getModuleHiMap as_source `thenRn` \ himap ->
- case (lookupFM himap (moduleString mod_name)) of
+ getModuleHiMap from_hi_boot `thenRn` \ himap ->
+ case (lookupFM himap (moduleUserString mod_name)) of
-- Found the file
- Just fpath -> readIface fpath
- -- Hack alert! When compiling PrelBase we have to load the
- -- decls for packCString# and friends; they are 'thin-air' Ids
- -- (see PrelInfo.lhs). So if we don't find the HiFile we quietly
- -- look for a .hi-boot file instead, and use that
- Nothing | thinAirLoop mod_name as_source
- -> findAndReadIface doc_str mod_name HiBootFile
- | otherwise
- -> traceRn (ptext SLIT("...failed")) `thenRn_`
- returnRn Nothing
+ Just fpath -> readIface mod_name fpath
+ Nothing -> traceRn (ptext SLIT("...failed")) `thenRn_`
+ returnRn Nothing
where
- thinAirLoop mod_name HiFile = mod_name `elem` thinAirModules
- thinAirLoop mod_name hif = False
+ hif = moduleIfaceFlavour mod_name
+ from_hi_boot = bootFlavour hif
trace_msg = sep [hsep [ptext SLIT("Reading"),
- case as_source of { HiBootFile -> ptext SLIT("[boot]"); other -> empty},
+ if from_hi_boot then ptext SLIT("[boot]") else empty,
ptext SLIT("interface for"),
pprModule mod_name <> semi],
nest 4 (ptext SLIT("reason:") <+> doc_str)]
@readIface@ tries just the one file.
\begin{code}
-readIface :: String -> RnMG (Maybe ParsedIface)
+readIface :: Module -> (String, Bool) -> RnMG (Maybe (Module, ParsedIface))
-- Nothing <=> file not found, or unreadable, or illegible
-- Just x <=> successfully found and parsed
-readIface file_path
+readIface requested_mod (file_path, is_dll)
= ioToRnMG (hGetStringBuffer file_path) `thenRn` \ read_result ->
case read_result of
Right contents ->
case parseIface contents (mkSrcLoc (mkFastString file_path) 1) of
- Failed err -> failWithRn Nothing err
- Succeeded (PIface iface) ->
- if opt_D_show_rn_imports then
- putDocRn (hcat[ptext SLIT("Read "), text file_path]) `thenRn_`
- returnRn (Just iface)
- else
- returnRn (Just iface)
-
- Left err ->
- if isDoesNotExistError err then
- returnRn Nothing
- else
- failWithRn Nothing (cannaeReadFile file_path err)
+ Failed err -> failWithRn Nothing err
+ Succeeded (PIface mod_nm iface) ->
+ (if mod_nm /= moduleFS requested_mod then
+ addWarnRn (hsep [ ptext SLIT("Something is amiss; requested module name")
+ , pprModule requested_mod
+ , ptext SLIT("differs from name found in the interface file ")
+ , pprEncodedFS mod_nm
+ ])
+ else
+ returnRn ()) `thenRn_`
+ let
+ the_mod
+ | is_dll = mkDynamicModule requested_mod
+ | otherwise = requested_mod
+ in
+ if opt_D_show_rn_imports then
+ putDocRn (hcat[ptext SLIT("Read module "), pprEncodedFS mod_nm,
+ ptext SLIT(" from "), text file_path]) `thenRn_`
+ returnRn (Just (the_mod, iface))
+ else
+ returnRn (Just (the_mod, iface))
+
+ Left err
+ | isDoesNotExistError err -> returnRn Nothing
+ | otherwise -> failWithRn Nothing (cannaeReadFile file_path err)
+
\end{code}
%*********************************************************
\begin{code}
mkSearchPath :: Maybe String -> SearchPath
-mkSearchPath Nothing = [(".",".hi")]
-mkSearchPath (Just s)
- = go s
+mkSearchPath Nothing = [(".",".hi")] -- ToDo: default should be to look in
+ -- the directory the module we're compiling
+ -- lives.
+mkSearchPath (Just s) = go s
where
go "" = []
go s =
projects / ghc-hetmet.git / blobdiff