#include "HsVersions.h"
-import CmdLineOpts ( DynFlag(..), opt_IgnoreIfacePragmas )
+import CmdLineOpts ( opt_IgnoreIfacePragmas )
import HscTypes ( ModuleLocation(..),
ModIface(..), emptyModIface,
VersionInfo(..),
DeclsMap, GatedDecl, IfaceInsts, IfaceRules,
AvailInfo, GenAvailInfo(..), Avails, Deprecations(..)
)
-import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..),
+import HsSyn ( TyClDecl(..), InstDecl(..),
HsType(..), ConDecl(..),
FixitySig(..), RuleDecl(..),
tyClDeclNames
import Name ( Name {-instance NamedThing-}, nameOccName,
nameModule, isLocalName, nameIsLocalOrFrom,
NamedThing(..),
- mkNameEnv, extendNameEnv
)
+import Name ( mkNameEnv, extendNameEnv )
import Module ( Module,
moduleName, isModuleInThisPackage,
ModuleName, WhereFrom(..),
extendModuleEnv, mkVanillaModule
)
import RdrName ( RdrName, rdrNameOcc )
-import NameSet
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}
-- CHECK WHETHER WE HAVE IT ALREADY
case lookupIfaceByModName hit pit mod_name of {
- Just iface -> returnRn (iface, Nothing) ; -- Already loaded
- Nothing ->
+ Just iface | case from of
+ ImportByUser -> not (mi_boot iface)
+ ImportByUserSource -> mi_boot iface
+ ImportBySystem -> 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
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 ->
loadExport :: Module -> ExportItem -> RnM d (ModuleName, Avails)
loadExport this_mod (mod, entities)
- | 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
- -- 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!
-
- | otherwise
= mapRn (load_entity mod) entities `thenRn` \ avails ->
returnRn (mod, avails)
where
-> 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 mod decl `thenRn` \ full_avail ->
let
-- 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 (name,txt))
\end{code}
findAndReadIface doc_str mod_name hi_boot_file
= traceRn trace_msg `thenRn_`
+
ioToRnM (findModule mod_name) `thenRn` \ maybe_found ->
- doptRn Opt_D_dump_rn_trace `thenRn` \ rn_trace ->
case maybe_found of
+
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 ->
+ -> readIface (mkHiPath hi_boot_file (ml_hi_file locn)) `thenRn` \ read_result ->
case read_result of
Left bad -> returnRn (Left bad)
Right iface
ptext SLIT("interface for"),
ppr mod_name <> semi],
nest 4 (ptext SLIT("reason:") <+> doc_str)]
+
+mkHiPath hi_boot_file (Just path)
+ | hi_boot_file = path ++ "-boot-5"
+ | otherwise = path
\end{code}
@readIface@ tries just the one file.
\begin{code}
-readIface :: Bool -> String -> IO (Either Message ParsedIface)
+readIface :: String -> RnM d (Either Message ParsedIface)
-- Nothing <=> file not found, or unreadable, or illegible
-- Just x <=> successfully found and parsed
-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#,
+readIface file_path
+ = 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 _ (PIface iface) -> returnRn (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.
+ }
+ where
+ init_parser_state = PState{ bol = 0#, atbol = 1#,
context = [],
glasgow_exts = 1#,
- loc = mkSrcLoc (mkFastString file_path) 1 } of
- 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.
- )
- `catch`
- (\ io_err -> bale_out (text (show io_err))))
- where
- bale_out err = return (Left (badIfaceFile file_path err))
+ loc = mkSrcLoc (mkFastString file_path) 1 }
+
+ bale_out err = returnRn (Left (badIfaceFile file_path err))
\end{code}