#include "HsVersions.h"
import DriverState ( v_GhcMode, isCompManagerMode )
-import DriverUtil ( splitFilename )
-import CmdLineOpts ( opt_IgnoreIfacePragmas )
+import DriverUtil ( replaceFilenameSuffix )
+import CmdLineOpts ( DynFlag(..) )
import Parser ( parseIface )
import HscTypes ( ModIface(..), emptyModIface,
- ExternalPackageState(..),
- VersionInfo(..), ImportedModuleInfo,
- lookupIfaceByModName, RdrExportItem, WhatsImported(..),
- ImportVersion, WhetherHasOrphans, IsBootInterface,
+ ExternalPackageState(..), noDependencies,
+ VersionInfo(..), Usage(..),
+ lookupIfaceByModName, RdrExportItem,
+ IsBootInterface,
DeclsMap, GatedDecl, IfaceInsts, IfaceRules, mkIfaceDecls,
AvailInfo, GenAvailInfo(..), ParsedIface(..), IfaceDeprecs,
Avails, availNames, availName, Deprecations(..)
import TcRnMonad
import PrelNames ( gHC_PRIM_Name, gHC_PRIM )
-import PrelInfo ( ghcPrimExports, cCallableClassDecl, cReturnableClassDecl, assertDecl )
+import PrelInfo ( ghcPrimExports )
import Name ( Name {-instance NamedThing-},
nameModule, isInternalName )
import NameEnv
import NameSet
import Id ( idName )
import MkId ( seqId )
-import Packages ( preludePackage )
+import Packages ( basePackage )
import Module ( Module, ModuleName, ModLocation(ml_hi_file),
- moduleName, isHomeModule, mkVanillaModule,
- extendModuleEnv
+ moduleName, isHomeModule, mkPackageModule,
+ extendModuleEnv, lookupModuleEnvByName
)
import RdrName ( RdrName, mkRdrUnqual, rdrNameOcc, nameRdrName )
-import OccName ( OccName, mkWorkerOcc, mkClassTyConOcc, mkClassDataConOcc,
- mkSuperDictSelOcc, mkGenOcc1, mkGenOcc2 )
+import OccName ( OccName, mkClassTyConOcc, mkClassDataConOcc,
+ mkSuperDictSelOcc, mkGenOcc1, mkGenOcc2,
+ mkDataConWrapperOcc, mkDataConWorkerOcc )
import TyCon ( DataConDetails(..) )
import SrcLoc ( noSrcLoc, mkSrcLoc )
import Maybes ( maybeToBool )
import StringBuffer ( hGetStringBuffer )
import FastString ( mkFastString )
import ErrUtils ( Message )
-import Finder ( findModule, findPackageModule )
-import Lex
+import Finder ( findModule, findPackageModule,
+ hiBootExt, hiBootVerExt )
+import Lexer
import FiniteMap
import ListSetOps ( minusList )
import Outputable
import Bag
import BinIface ( readBinIface )
import Panic
-import Config
import EXCEPTION as Exception
import DATA_IOREF ( readIORef )
-- But it's OK to fail; perhaps the module has changed, and that interface
-- is no longer used.
- -- tryLoadInterface guarantees to return with eps_mod_info m --> (..., True)
- -- (If the load fails, we plug in a vanilla placeholder)
loadInterface doc_str mod_name from
- = getHpt `thenM` \ hpt ->
- getModule `thenM` \ this_mod ->
- getEps `thenM` \ eps@(EPS { eps_PIT = pit }) ->
+ = getHpt `thenM` \ hpt ->
+ getModule `thenM` \ this_mod ->
+ getImports `thenM` \ import_avails ->
+ getEps `thenM` \ eps@(EPS { eps_PIT = pit }) ->
-- CHECK WHETHER WE HAVE IT ALREADY
case lookupIfaceByModName hpt pit mod_name of {
other ->
let
- mod_map = eps_imp_mods eps
- mod_info = lookupFM mod_map mod_name
+ mod_map = imp_dep_mods import_avails
+ mod_info = lookupModuleEnvByName mod_map mod_name
hi_boot_file
= case (from, mod_info) of
redundant_source_import
= case (from, mod_info) of
- (ImportByUser True, Just (_,False)) -> True
- other -> False
+ (ImportByUser True, Just (_, False)) -> True
+ other -> False
in
-- Issue a warning for a redundant {- SOURCE -} import
| otherwise
-> let -- Not found, so add an empty export env to
-- the EPS map so that we don't look again
- fake_mod = mkVanillaModule mod_name
+ fake_mod = mkPackageModule mod_name
fake_iface = emptyModIface fake_mod
new_eps = eps { eps_PIT = extendModuleEnv pit fake_mod fake_iface }
in
vers_rules = rule_vers,
vers_decls = decls_vers }
- -- For an explicit user import, add to mod_map info about
- -- the things the imported module depends on, extracted
- -- from its usage info; and delete the module itself, which is now in the PIT
- usages = pi_usages iface
- mod_map1 = case from of
- ImportByUser _ -> addModDeps mod is_loaded usages mod_map
- other -> mod_map
- mod_map2 = delFromFM mod_map1 mod_name
-
- -- mod_deps is a pruned version of usages that records only what
- -- module imported, but nothing about versions.
- -- This info is used when demand-linking the dependencies
- mod_deps = [ (mod,orph,boot,NothingAtAll) | (mod,orph,boot,_) <- usages]
-
- this_mod_name = moduleName this_mod
- is_loaded m = m == this_mod_name
- || maybeToBool (lookupIfaceByModName hpt 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
+ -- Even home modules loaded by this route (which only
+ -- happens in OneShot mode) are put in the PIT
has_orphans = pi_orphan iface
new_pit = extendModuleEnv pit mod mod_iface
mod_iface = ModIface { mi_module = mod, mi_package = pi_pkg iface,
mi_orphan = has_orphans, mi_boot = hi_boot_file,
mi_exports = avails,
mi_fixities = fix_env, mi_deprecs = deprec_env,
- mi_usages = mod_deps, -- Used for demand-loading,
- -- not for version info
+ mi_deps = pi_deps iface,
+ mi_usages = panic "No mi_usages in PIT",
mi_decls = panic "No mi_decls in PIT",
mi_globals = Nothing
}
new_eps = eps { eps_PIT = new_pit,
eps_decls = new_decls,
eps_insts = new_insts,
- eps_rules = new_rules,
- eps_imp_mods = mod_map2 }
+ eps_rules = new_rules }
in
setEps new_eps `thenM_`
returnM mod_iface
}}
-----------------------------------------------------
--- Adding module dependencies from the
--- import decls in the interface file
------------------------------------------------------
-
-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 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))]
- filtered_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))
- | (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_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
-----------------------------------------------------
returnM (mod, avails)
where
load_entity mod (Avail occ)
- = newGlobalName mod occ `thenM` \ name ->
+ = newGlobalName2 mod occ `thenM` \ name ->
returnM (Avail name)
load_entity mod (AvailTC occ occs)
- = newGlobalName mod occ `thenM` \ name ->
- mappM (newGlobalName mod) occs `thenM` \ names ->
+ = newGlobalName2 mod occ `thenM` \ name ->
+ mappM (newGlobalName2 mod) occs `thenM` \ names ->
returnM (AvailTC name names)
returnM (vers, (decls_map', n_slurped))
loadDecl mod (version_map, decls_map) (version, decl)
- = getTyClDeclBinders mod decl `thenM` \ avail ->
+ = maybeStripPragmas decl `thenM` \ decl ->
+ getTyClDeclBinders mod decl `thenM` \ avail ->
getSysBinders mod decl `thenM` \ sys_names ->
let
full_avail = case avail of
new_version_map = extendNameEnv version_map main_name version
in
- traceRn (text "Loading" <+> ppr full_avail) `thenM_`
+-- traceRn (text "Loading" <+> ppr full_avail) `thenM_`
returnM (new_version_map, new_decls_map)
-
+maybeStripPragmas sig@(IfaceSig {tcdIdInfo = idinfo})
+ = doptM Opt_IgnoreInterfacePragmas `thenM` \ ignore_prags ->
+ if ignore_prags
+ then returnM sig{ tcdIdInfo = [] }
+ else returnM sig
+maybeStripPragmas other
+ = returnM other
-----------------
getTyClDeclBinders :: Module -> RdrNameTyClDecl -> TcRn m AvailInfo
-- on RdrNames, returning OccNames
getSysBinders mod (ClassDecl {tcdName = cname, tcdCtxt = cxt, tcdLoc = loc})
- = sequenceM [new_sys_bndr mod n loc | n <- sys_occs]
+ = mapM (new_sys_bndr mod loc) sys_occs
where
-- C.f. TcClassDcl.tcClassDecl1
- sys_occs = tc_occ : data_occ : dw_occ : sc_sel_occs
+ sys_occs = tc_occ : data_occ : dwrap_occ : dwork_occ : sc_sel_occs
cls_occ = rdrNameOcc cname
data_occ = mkClassDataConOcc cls_occ
- dw_occ = mkWorkerOcc data_occ
+ dwrap_occ = mkDataConWrapperOcc data_occ
+ dwork_occ = mkDataConWorkerOcc data_occ
tc_occ = mkClassTyConOcc cls_occ
sc_sel_occs = [mkSuperDictSelOcc n cls_occ | n <- [1..length cxt]]
tcdGeneric = Just want_generic, tcdLoc = loc})
-- The 'Just' is because this is an interface-file decl
-- so it will say whether to derive generic stuff for it or not
- = sequenceM ([new_sys_bndr mod n loc | n <- gen_occs] ++
- map con_sys_occ cons)
+ = mapM (new_sys_bndr mod loc) (gen_occs ++ concatMap mk_con_occs cons)
where
+ new = new_sys_bndr
-- c.f. TcTyDecls.tcTyDecl
tc_occ = rdrNameOcc tc_name
gen_occs | want_generic = [mkGenOcc1 tc_occ, mkGenOcc2 tc_occ]
| otherwise = []
- con_sys_occ (ConDecl name _ _ _ loc)
- = new_sys_bndr mod (mkWorkerOcc (rdrNameOcc name)) loc
+ mk_con_occs (ConDecl name _ _ _ _)
+ = [mkDataConWrapperOcc con_occ, mkDataConWorkerOcc con_occ]
+ where
+ con_occ = rdrNameOcc name -- The "source name"
getSysBinders mod decl = returnM []
-new_sys_bndr mod occ loc = newTopBinder mod (mkRdrUnqual occ) loc
+new_sys_bndr mod loc occ = newTopBinder mod (mkRdrUnqual occ) loc
-----------------------------------------------------
-- (Note that we do let the inst decl in if it mentions
-- no tycons at all. Hence the null free_ty_names.)
in
- traceRn ((text "Load instance for" <+> ppr inst_ty') $$ ppr free_tcs) `thenM_`
+-- traceRn ((text "Load instance for" <+> ppr inst_ty') $$ ppr free_tcs) `thenM_`
returnM ((gate_fn, (mod, decl)) `consBag` insts)
-> (Version, [RdrNameRuleDecl])
-> RnM (Version, IfaceRules)
loadRules mod (rule_bag, n_slurped) (version, rules)
- | null rules || opt_IgnoreIfacePragmas
- = returnM (version, (rule_bag, n_slurped))
- | otherwise
- = mappM (loadRule mod) rules `thenM` \ new_rules ->
- returnM (version, (rule_bag `unionBags` listToBag new_rules, n_slurped))
+ = doptM Opt_IgnoreInterfacePragmas `thenM` \ ignore_prags ->
+ if null rules || ignore_prags
+ then returnM (version, (rule_bag, n_slurped))
+ else mappM (loadRule mod) rules `thenM` \ new_rules ->
+ returnM (version, (rule_bag `unionBags`
+ listToBag new_rules, n_slurped))
loadRule :: Module -> RdrNameRuleDecl -> RnM (GatedDecl RdrNameRuleDecl)
-- "Gate" the rule simply by whether the rule variable is
returnM (DeprecSome env)
loadDeprec deprec_env (n, txt)
= lookupGlobalOccRn n `thenM` \ name ->
- traceRn (text "Loaded deprecation(s) for" <+> ppr name <> colon <+> ppr txt) `thenM_`
+-- traceRn (text "Loaded deprecation(s) for" <+> ppr name <> colon <+> ppr txt) `thenM_`
returnM (extendNameEnv deprec_env name (name,txt))
\end{code}
decls = mkIfaceDecls new_decls new_rules new_insts
mod_iface = ModIface { mi_module = mod, mi_package = pi_pkg iface,
- mi_version = version,
+ mi_version = version, mi_deps = pi_deps iface,
mi_exports = avails, mi_usages = usages,
mi_boot = False, mi_orphan = pi_orphan iface,
mi_fixities = fix_env, mi_deprecs = deprec_env,
loadHomeInsts insts = mappM rnInstDecl insts
------------------
-loadHomeUsage :: ImportVersion OccName
- -> TcRn m (ImportVersion Name)
-loadHomeUsage (mod_name, orphans, is_boot, whats_imported)
- = rn_imps whats_imported `thenM` \ whats_imported' ->
- returnM (mod_name, orphans, is_boot, whats_imported')
+loadHomeUsage :: Usage OccName -> TcRn m (Usage Name)
+loadHomeUsage usage
+ = mappM rn_imp (usg_entities usage) `thenM` \ entities' ->
+ returnM (usage { usg_entities = entities' })
where
- rn_imps NothingAtAll = returnM NothingAtAll
- rn_imps (Everything v) = returnM (Everything v)
- rn_imps (Specifically mv ev items rv) = mappM rn_imp items `thenM` \ items' ->
- returnM (Specifically mv ev items' rv)
- rn_imp (occ,vers) = newGlobalName mod_name occ `thenM` \ name ->
+ mod_name = usg_name usage
+ rn_imp (occ,vers) = newGlobalName2 mod_name occ `thenM` \ name ->
returnM (name,vers)
\end{code}
ioToTcRn (findHiFile mod_name hi_boot_file) `thenM` \ maybe_found ->
case maybe_found of
- Nothing ->
+ Left files ->
traceRn (ptext SLIT("...not found")) `thenM_`
- returnM (Left (noIfaceErr mod_name hi_boot_file))
+ getDOpts `thenM` \ dflags ->
+ returnM (Left (noIfaceErr dflags mod_name hi_boot_file files))
- Just (wanted_mod, file_path) ->
+ Right (wanted_mod, file_path) ->
traceRn (ptext SLIT("readIFace") <+> text file_path) `thenM_`
readIface wanted_mod file_path hi_boot_file `thenM` \ read_result ->
ppr mod_name <> semi],
nest 4 (ptext SLIT("reason:") <+> doc_str)]
-findHiFile :: ModuleName -> IsBootInterface -> IO (Maybe (Module, FilePath))
+findHiFile :: ModuleName -> IsBootInterface
+ -> IO (Either [FilePath] (Module, FilePath))
findHiFile mod_name hi_boot_file
= do {
-- In interactive or --make mode, we are *not allowed* to demand-load
else findPackageModule mod_name ;
case maybe_found of {
- Nothing -> return Nothing ;
+ Left files -> return (Left files) ;
- Just (mod,loc) -> do {
+ Right (mod,loc) -> do {
-- Return the path to M.hi, M.hi-boot, or M.hi-boot-n as appropriate
let { hi_path = ml_hi_file loc ;
- (hi_base, _hi_suf) = splitFilename hi_path ;
- hi_boot_path = hi_base ++ ".hi-boot" ;
- hi_boot_ver_path = hi_base ++ ".hi-boot-" ++ cHscIfaceFileVersion } ;
+ hi_boot_path = replaceFilenameSuffix hi_path hiBootExt ;
+ hi_boot_ver_path = replaceFilenameSuffix hi_path hiBootVerExt
+ };
if not hi_boot_file then
- return (Just (mod, hi_path))
+ return (Right (mod, hi_path))
else do {
hi_ver_exists <- doesFileExist hi_boot_ver_path ;
- if hi_ver_exists then return (Just (mod, hi_boot_ver_path))
- else return (Just (mod, hi_boot_path))
+ if hi_ver_exists then return (Right (mod, hi_boot_ver_path))
+ else return (Right (mod, hi_boot_path))
}}}}
\end{code}
@readIface@ tries just the one file.
\begin{code}
-readIface :: Module -> String -> IsBootInterface -> TcRn m (Either IOError ParsedIface)
+readIface :: Module -> String -> IsBootInterface -> TcRn m (Either Exception ParsedIface)
-- Nothing <=> file not found, or unreadable, or illegible
-- Just x <=> successfully found and parsed
readIface mod file_path is_hi_boot_file
- = ioToTcRn_no_fail (read_iface mod file_path is_hi_boot_file)
+ = do dflags <- getDOpts
+ ioToTcRn (tryMost (read_iface mod dflags file_path is_hi_boot_file))
-read_iface mod file_path is_hi_boot_file
+read_iface mod dflags file_path is_hi_boot_file
| is_hi_boot_file -- Read ascii
= do { buffer <- hGetStringBuffer file_path ;
- case parseIface buffer (mkPState loc exts) of
+ case unP parseIface (mkPState buffer loc dflags) of
POk _ iface | wanted_mod_name == actual_mod_name
-> return iface
| otherwise
actual_mod_name = pi_mod iface
err = hiModuleNameMismatchWarn wanted_mod_name actual_mod_name
- PFailed err -> throwDyn (ProgramError (showSDoc err))
+ PFailed loc1 loc2 err ->
+ throwDyn (ProgramError (showPFailed loc1 loc2 err))
}
| otherwise -- Read binary
= readBinIface file_path
where
- exts = ExtFlags {glasgowExtsEF = True,
- ffiEF = True,
- withEF = True,
- parrEF = True}
- loc = mkSrcLoc (mkFastString file_path) 1
+ loc = mkSrcLoc (mkFastString file_path) 1 0
\end{code}
ghcPrimIface :: ParsedIface
ghcPrimIface = ParsedIface {
pi_mod = gHC_PRIM_Name,
- pi_pkg = preludePackage,
+ pi_pkg = basePackage,
+ pi_deps = noDependencies,
pi_vers = 1,
pi_orphan = False,
pi_usages = [],
pi_exports = (1, [(gHC_PRIM_Name, ghcPrimExports)]),
- pi_decls = [(1,cCallableClassDecl),
- (1,cReturnableClassDecl),
- (1,assertDecl)],
+ pi_decls = [],
pi_fixity = [FixitySig (nameRdrName (idName seqId))
(Fixity 0 InfixR) noSrcLoc],
-- seq is infixr 0
%*********************************************************
\begin{code}
-noIfaceErr mod_name boot_file
- = ptext SLIT("Could not find interface file for") <+> quotes (ppr mod_name)
- -- We used to print the search path, but we can't do that
- -- now, because it's hidden inside the finder.
- -- Maybe the finder should expose more functions.
-
badIfaceFile file err
= vcat [ptext SLIT("Bad interface file:") <+> text file,
nest 4 err]
projects / ghc-hetmet.git / blobdiff