#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(..),
- HsType(..), ConDecl(..),
- FixitySig(..), RuleDecl(..),
- tyClDeclNames
+import HsSyn ( TyClDecl(..), InstDecl(..),
+ HsType(..), FixitySig(..), RuleDecl(..),
+ tyClDeclNames, tyClDeclSysNames
)
import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl,
extractHsTyRdrNames
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 Config
-import Monad ( when )
+import Directory
\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 ->
-> 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 lookupIfaceName free_names `thenRn` \ gate_names ->
- returnRn ((gate_names, (mod, InstD decl)) `consBag` insts)
+ 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)
= lookupIfaceName var `thenRn` \ var_name ->
- returnRn ([var_name], (mod, RuleD decl))
+ returnRn ([var_name], (mod, decl))
-----------------------------------------------------
-> RdrNameTyClDecl
-> RnM d AvailInfo
-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 mod (IfaceSig var ty prags src_loc)
= newTopBinder mod var src_loc `thenRn` \ var_name ->
returnRn (Avail var_name)
getTyClDeclBinders mod tycl_decl
- = mapRn do_one (tyClDeclNames tycl_decl) `thenRn` \ (main_name:sub_names) ->
+ = new_top_bndrs mod (tyClDeclNames tycl_decl) `thenRn` \ (main_name:sub_names) ->
returnRn (AvailTC main_name (main_name : sub_names))
- where
- do_one (name,loc) = newTopBinder mod 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.
-
-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 mod (ClassDecl _ cname _ _ sigs _ names src_loc)
- = sequenceRn [newTopBinder mod n src_loc | n <- names]
+-----------------
+getIfaceDeclBinders mod (IfaceSig var ty prags src_loc)
+ = newTopBinder mod var src_loc `thenRn` \ var_name ->
+ returnRn (Avail var_name)
-getSysTyClDeclBinders mod (TyData _ _ _ _ cons _ _ _ _ _)
- = sequenceRn [newTopBinder mod wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons]
+getIfaceDeclBinders mod tycl_decl
+ = new_top_bndrs mod (tyClDeclNames tycl_decl) `thenRn` \ (main_name:sub_names) ->
+ new_top_bndrs mod (tyClDeclSysNames tycl_decl) `thenRn` \ sys_names ->
+ returnRn (AvailTC main_name (main_name : (sys_names ++ sub_names)))
-getSysTyClDeclBinders mod other_decl
- = returnRn []
+-----------------
+new_top_bndrs mod names_w_locs
+ = sequenceRn [newTopBinder mod name loc | (name,loc) <- names_w_locs]
\end{code}
+
%*********************************************************
%* *
\subsection{Reading an interface file}
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 ->
+ -> 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))
+ 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 (Just hi_path) = ml_hi_file locn
+ hi_boot_path = hi_path ++ "-boot"
+ hi_boot_ver_path = hi_path ++ "-boot-" ++ cHscIfaceFileVersion
\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}
projects / ghc-hetmet.git / blobdiff