\begin{code}
module RnHiFiles (
- readIface, findAndReadIface, loadInterface, loadHomeInterface,
- tryLoadInterface, loadOrphanModules,
- loadExports, loadFixDecls, loadDeprecs,
-
- lookupFixityRn,
-
- getTyClDeclBinders
+ readIface, loadInterface, loadHomeInterface,
+ loadOrphanModules,
+ loadOldIface,
+ ParsedIface(..)
) where
#include "HsVersions.h"
import DriverState ( v_GhcMode, isCompManagerMode )
-import DriverUtil ( splitFilename )
+import DriverUtil ( replaceFilenameSuffix )
import CmdLineOpts ( opt_IgnoreIfacePragmas )
import Parser ( parseIface )
-import HscTypes ( ModuleLocation(..),
- ModIface(..), emptyModIface,
- VersionInfo(..), ImportedModuleInfo,
- lookupIfaceByModName, RdrExportItem,
- ImportVersion, WhetherHasOrphans, IsBootInterface,
- DeclsMap, GatedDecl, IfaceInsts, IfaceRules,
- AvailInfo, GenAvailInfo(..), Avails, Deprecations(..)
+import HscTypes ( ModIface(..), emptyModIface,
+ ExternalPackageState(..), noDependencies,
+ VersionInfo(..), Usage(..),
+ lookupIfaceByModName, RdrExportItem,
+ IsBootInterface,
+ DeclsMap, GatedDecl, IfaceInsts, IfaceRules, mkIfaceDecls,
+ AvailInfo, GenAvailInfo(..), ParsedIface(..), IfaceDeprecs,
+ Avails, availNames, availName, Deprecations(..)
)
-import HsSyn ( TyClDecl(..), InstDecl(..), RuleDecl(..),
- tyClDeclNames, tyClDeclSysNames, hsTyVarNames,
- getHsInstHead,
+import HsSyn ( TyClDecl(..), InstDecl(..), RuleDecl(..), ConDecl(..),
+ hsTyVarNames, splitHsInstDeclTy, tyClDeclName, tyClDeclNames
)
import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl )
-import RnHsSyn ( extractHsTyNames_s )
-import BasicTypes ( Version, defaultFixity )
+import RnHsSyn ( RenamedInstDecl, RenamedRuleDecl, RenamedTyClDecl,
+ extractHsTyNames_s )
+import BasicTypes ( Version, FixitySig(..), Fixity(..), FixityDirection(..) )
+import RnSource ( rnIfaceRuleDecl, rnTyClDecl, rnInstDecl )
import RnTypes ( rnHsType )
import RnEnv
-import RnMonad
+import TcRnMonad
import PrelNames ( gHC_PRIM_Name, gHC_PRIM )
+import PrelInfo ( ghcPrimExports, cCallableClassDecl, cReturnableClassDecl )
import Name ( Name {-instance NamedThing-},
- nameModule, isInternalName, nameIsLocalOrFrom
- )
+ nameModule, isInternalName )
import NameEnv
import NameSet
-import Module
-import RdrName ( rdrNameOcc )
-import SrcLoc ( mkSrcLoc )
-import Maybes ( maybeToBool, orElse )
+import Id ( idName )
+import MkId ( seqId )
+import Packages ( basePackage )
+import Module ( Module, ModuleName, ModLocation(ml_hi_file),
+ moduleName, isHomeModule, mkPackageModule,
+ extendModuleEnv, lookupModuleEnvByName
+ )
+import RdrName ( RdrName, mkRdrUnqual, rdrNameOcc, nameRdrName )
+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 Finder ( findModule, findPackageModule,
+ hiBootExt, hiBootVerExt )
import Lex
import FiniteMap
import ListSetOps ( minusList )
import Outputable
import Bag
-import BinIface ( {- just instances -} )
-import qualified Binary
+import BinIface ( readBinIface )
import Panic
-import Config
-import IOExts
-import Exception
-import Dynamic ( fromDynamic )
+import EXCEPTION as Exception
+import DATA_IOREF ( readIORef )
+
import Directory
-import List ( isSuffixOf )
\end{code}
%*********************************************************
\begin{code}
-loadHomeInterface :: SDoc -> Name -> RnM d ModIface
+loadHomeInterface :: SDoc -> Name -> TcRn m ModIface
loadHomeInterface doc_str name
= ASSERT2( not (isInternalName name), ppr name <+> parens doc_str )
loadInterface doc_str (moduleName (nameModule name)) ImportBySystem
-loadOrphanModules :: [ModuleName] -> RnM d ()
+loadOrphanModules :: [ModuleName] -> TcRn m ()
loadOrphanModules mods
- | null mods = returnRn ()
+ | null mods = returnM ()
| otherwise = traceRn (text "Loading orphan modules:" <+>
- fsep (map ppr mods)) `thenRn_`
- mapRn_ load mods `thenRn_`
- returnRn ()
+ fsep (map ppr mods)) `thenM_`
+ mappM_ load mods `thenM_`
+ returnM ()
where
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 ModIface
-loadInterface doc mod from
- = tryLoadInterface doc mod from `thenRn` \ (ifaces, maybe_err) ->
- case maybe_err of
- Nothing -> returnRn ifaces
- 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.
+loadInterface :: SDoc -> ModuleName -> WhereFrom -> TcRn m ModIface
+ -- Returns Nothing if failed
+ -- If we can't find an interface file, and we are doing ImportForUsage,
+ -- just fail in the monad, and modify anything else
+ -- Otherwise, if we can't find an interface file,
+ -- add an error message to the monad (the first time only)
+ -- and return emptyIface
+ -- The "first time only" part is done by modifying the PackageIfaceTable
+ -- to have an empty entry
+ --
+ -- The ImportForUsage case is because 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 ->
- getModuleRn `thenRn` \ this_mod ->
- getIfacesRn `thenRn` \ ifaces@(Ifaces { iPIT = pit }) ->
+loadInterface doc_str mod_name from
+ = 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 hit pit mod_name of {
+ case lookupIfaceByModName hpt pit mod_name of {
Just iface | case from of
- ImportByUser -> not (mi_boot iface)
- ImportByUserSource -> mi_boot iface
- ImportBySystem -> True
- -> returnRn (iface, Nothing) ; -- Already loaded
+ ImportByUser src_imp -> src_imp == mi_boot iface
+ ImportForUsage src_imp -> src_imp == mi_boot iface
+ ImportBySystem -> True
+ -> returnM iface ; -- 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
other ->
let
- mod_map = iImpModInfo ifaces
- 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
- (ImportByUser, _) -> False -- Not hi-boot
- (ImportByUserSource, _) -> True -- hi-boot
+ (ImportByUser is_boot, _) -> is_boot
+ (ImportForUsage is_boot, _) -> is_boot
(ImportBySystem, Just (_, is_boot)) -> is_boot
(ImportBySystem, Nothing) -> False
-- We're importing a module we know absolutely
redundant_source_import
= case (from, mod_info) of
- (ImportByUserSource, Just (_,False)) -> True
- other -> False
+ (ImportByUser True, Just (_, False)) -> True
+ other -> False
in
-- Issue a warning for a redundant {- SOURCE -} import
-- NB that we arrange to read all the ordinary imports before
-- any of the {- SOURCE -} imports
- warnCheckRn (not redundant_source_import)
- (warnRedundantSourceImport mod_name) `thenRn_`
+ warnIf redundant_source_import
+ (warnRedundantSourceImport mod_name) `thenM_`
-- 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_`
+ -- which doesn't call loadInterface
+ warnIf
+ (isHomeModule this_mod && moduleName this_mod == mod_name)
+ (warnSelfImport this_mod) `thenM_`
-- READ THE MODULE IN
findAndReadIface doc_str mod_name hi_boot_file
- `thenRn` \ read_result ->
+ `thenM` \ 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
- 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 (fake_iface, Just err) ;
+ Left err
+ | case from of { ImportForUsage _ -> True ; other -> False }
+ -> failM -- Fail with no error messages
+
+ | otherwise
+ -> let -- Not found, so add an empty export env to
+ -- the EPS map so that we don't look again
+ fake_mod = mkPackageModule mod_name
+ fake_iface = emptyModIface fake_mod
+ new_eps = eps { eps_PIT = extendModuleEnv pit fake_mod fake_iface }
+ in
+ setEps new_eps `thenM_`
+ addErr (elaborate err) `thenM_`
+ returnM fake_iface
+ where
+ elaborate err = hang (ptext SLIT("Failed to load interface for") <+>
+ quotes (ppr mod_name) <> colon) 4 err
+ ;
-- Found and parsed!
Right (mod, iface) ->
- -- LOAD IT INTO Ifaces
+ -- LOAD IT INTO EPS
-- 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).
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) ->
- 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 ->
- let
+ initRn (InterfaceMode mod) $
+ -- Set the module, for use when looking up occurrences
+ -- of names in interface decls and rules
+ loadDecls mod (eps_decls eps) (pi_decls iface) `thenM` \ (decls_vers, new_decls) ->
+ loadRules mod (eps_rules eps) (pi_rules iface) `thenM` \ (rule_vers, new_rules) ->
+ loadInstDecls mod (eps_insts eps) (pi_insts iface) `thenM` \ new_insts ->
+ loadExports (pi_exports iface) `thenM` \ (export_vers, avails) ->
+ loadFixDecls (pi_fixity iface) `thenM` \ fix_env ->
+ loadDeprecs (pi_deprecs iface) `thenM` \ deprec_env ->
+ let
version = VersionInfo { vers_module = pi_vers iface,
vers_exports = export_vers,
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
- mod_map1 = case from of
- ImportByUser -> addModDeps mod is_loaded (pi_usages iface) mod_map
- other -> mod_map
- 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
+ -- 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 = [], -- Will be filled in later
- mi_decls = panic "No mi_decls in PIT",
- mi_globals = Nothing
+ 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_ifaces = ifaces { iPIT = new_pit,
- iDecls = new_decls,
- iInsts = new_insts,
- iRules = new_rules,
- iImpModInfo = mod_map2 }
+ new_eps = eps { eps_PIT = new_pit,
+ eps_decls = new_decls,
+ eps_insts = new_insts,
+ eps_rules = new_rules }
in
- setIfacesRn new_ifaces `thenRn_`
- returnRn (mod_iface, Nothing)
+ 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
-----------------------------------------------------
-loadExports :: (Version, [RdrExportItem]) -> RnM d (Version, [(ModuleName,Avails)])
+loadExports :: (Version, [RdrExportItem]) -> TcRn m (Version, [(ModuleName,Avails)])
loadExports (vers, items)
- = mapRn loadExport items `thenRn` \ avails_s ->
- returnRn (vers, avails_s)
+ = mappM loadExport items `thenM` \ avails_s ->
+ returnM (vers, avails_s)
-loadExport :: RdrExportItem -> RnM d (ModuleName, Avails)
+loadExport :: RdrExportItem -> TcRn m (ModuleName, Avails)
loadExport (mod, entities)
- = mapRn (load_entity mod) entities `thenRn` \ avails ->
- returnRn (mod, avails)
+ = mappM (load_entity mod) entities `thenM` \ avails ->
+ returnM (mod, avails)
where
load_entity mod (Avail occ)
- = newGlobalName mod occ `thenRn` \ name ->
- returnRn (Avail name)
+ = newGlobalName2 mod occ `thenM` \ name ->
+ returnM (Avail name)
load_entity mod (AvailTC occ occs)
- = newGlobalName mod occ `thenRn` \ name ->
- mapRn (newGlobalName mod) occs `thenRn` \ names ->
- returnRn (AvailTC name names)
+ = newGlobalName2 mod occ `thenM` \ name ->
+ mappM (newGlobalName2 mod) occs `thenM` \ names ->
+ returnM (AvailTC name names)
-----------------------------------------------------
loadDecls :: Module
-> DeclsMap
-> [(Version, RdrNameTyClDecl)]
- -> RnM d (NameEnv Version, DeclsMap)
+ -> TcRn m (NameEnv Version, DeclsMap)
loadDecls mod (decls_map, n_slurped) decls
- = foldlRn (loadDecl mod) (emptyNameEnv, decls_map) decls `thenRn` \ (vers, decls_map') ->
- returnRn (vers, (decls_map', n_slurped))
+ = foldlM (loadDecl mod) (emptyNameEnv, decls_map) decls `thenM` \ (vers, decls_map') ->
+ returnM (vers, (decls_map', n_slurped))
loadDecl mod (version_map, decls_map) (version, decl)
- = getTyClDeclBinders mod decl `thenRn` \ (avail, sys_names) ->
+ = getTyClDeclBinders mod decl `thenM` \ avail ->
+ getSysBinders mod decl `thenM` \ sys_names ->
let
full_avail = case avail of
Avail n -> avail
new_version_map = extendNameEnv version_map main_name version
in
- traceRn (text "Loading" <+> ppr full_avail) `thenRn_`
- returnRn (new_version_map, new_decls_map)
+-- traceRn (text "Loading" <+> ppr full_avail) `thenM_`
+ returnM (new_version_map, new_decls_map)
+
+
+
+-----------------
+getTyClDeclBinders :: Module -> RdrNameTyClDecl -> TcRn m AvailInfo
+
+getTyClDeclBinders mod (IfaceSig {tcdName = var, tcdLoc = src_loc})
+ = newTopBinder mod var src_loc `thenM` \ var_name ->
+ returnM (Avail var_name)
+
+getTyClDeclBinders mod tycl_decl
+ = mapM new (tyClDeclNames tycl_decl) `thenM` \ names@(main_name:_) ->
+ returnM (AvailTC main_name names)
+ where
+ new (nm,loc) = newTopBinder mod nm loc
+
+--------------------------------
+-- The "system names" are extra implicit names *bound* by the decl.
+
+getSysBinders :: Module -> TyClDecl RdrName -> TcRn m [Name]
+-- Similar to tyClDeclNames, but returns the "implicit"
+-- or "system" names of the declaration. And it only works
+-- on RdrNames, returning OccNames
+
+getSysBinders mod (ClassDecl {tcdName = cname, tcdCtxt = cxt, tcdLoc = loc})
+ = mapM (new_sys_bndr mod loc) sys_occs
+ where
+ -- C.f. TcClassDcl.tcClassDecl1
+ sys_occs = tc_occ : data_occ : dwrap_occ : dwork_occ : sc_sel_occs
+ cls_occ = rdrNameOcc cname
+ data_occ = mkClassDataConOcc cls_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]]
+
+getSysBinders mod (TyData {tcdName = tc_name, tcdCons = DataCons cons,
+ 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
+ = 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 = []
+ 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 loc occ = newTopBinder mod (mkRdrUnqual occ) loc
+
-----------------------------------------------------
-- Loading fixity decls
-----------------------------------------------------
-loadFixDecls mod decls
- = mapRn (loadFixDecl mod_name) decls `thenRn` \ to_add ->
- returnRn (mkNameEnv to_add)
- where
- mod_name = moduleName mod
+loadFixDecls decls
+ = mappM loadFixDecl decls `thenM` \ to_add ->
+ returnM (mkNameEnv to_add)
-loadFixDecl mod_name (rdr_name, fixity)
- = newGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name ->
- returnRn (name, fixity)
+loadFixDecl (FixitySig rdr_name fixity loc)
+ = lookupGlobalOccRn rdr_name `thenM` \ name ->
+ returnM (name, FixitySig name fixity loc)
-----------------------------------------------------
-- Loading instance decls
-----------------------------------------------------
-loadInstDecls :: Module
- -> IfaceInsts
+loadInstDecls :: Module -> IfaceInsts
-> [RdrNameInstDecl]
- -> RnM d IfaceInsts
+ -> RnM IfaceInsts
loadInstDecls mod (insts, n_slurped) decls
- = setModuleRn mod $
- foldlRn (loadInstDecl mod) insts decls `thenRn` \ insts' ->
- returnRn (insts', n_slurped)
+ = foldlM (loadInstDecl mod) insts decls `thenM` \ insts' ->
+ returnM (insts', n_slurped)
loadInstDecl mod insts decl@(InstDecl inst_ty _ _ _ _)
-- NOTICE that we rename the type before extracting its free
-- variables. The free-variable finder for a renamed HsType
-- does the Right Thing for built-in syntax like [] and (,).
- initIfaceRnMS mod (
- rnHsType (text "In an interface instance decl") inst_ty
- ) `thenRn` \ inst_ty' ->
+ rnHsType (text "In an interface instance decl") inst_ty `thenM` \ inst_ty' ->
let
- (tvs,(cls,tys)) = getHsInstHead inst_ty'
+ (tvs,_,cls,tys) = splitHsInstDeclTy inst_ty'
free_tcs = nameSetToList (extractHsTyNames_s tys) `minusList` hsTyVarNames tvs
gate_fn vis_fn = vis_fn cls && (null free_tcs || any vis_fn free_tcs)
+ -- The 'vis_fn' returns True for visible names
-- Here is the implementation of HOWEVER above
-- (Note that we do let the inst decl in if it mentions
-- no tycons at all. Hence the null free_ty_names.)
in
- returnRn ((gate_fn, (mod, decl)) `consBag` insts)
+-- traceRn ((text "Load instance for" <+> ppr inst_ty') $$ ppr free_tcs) `thenM_`
+ returnM ((gate_fn, (mod, decl)) `consBag` insts)
-- Loading Rules
-----------------------------------------------------
-loadRules :: Module -> IfaceRules
+loadRules :: Module
+ -> IfaceRules
-> (Version, [RdrNameRuleDecl])
- -> RnM d (Version, IfaceRules)
+ -> RnM (Version, IfaceRules)
loadRules mod (rule_bag, n_slurped) (version, rules)
| null rules || opt_IgnoreIfacePragmas
- = returnRn (version, (rule_bag, n_slurped))
+ = returnM (version, (rule_bag, n_slurped))
| otherwise
- = setModuleRn mod $
- mapRn (loadRule mod) rules `thenRn` \ new_rules ->
- returnRn (version, (rule_bag `unionBags` listToBag new_rules, n_slurped))
+ = mappM (loadRule mod) rules `thenM` \ new_rules ->
+ returnM (version, (rule_bag `unionBags` listToBag new_rules, n_slurped))
-loadRule :: Module -> RdrNameRuleDecl -> RnM d (GatedDecl RdrNameRuleDecl)
+loadRule :: Module -> RdrNameRuleDecl -> RnM (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 (\vis_fn -> vis_fn var_name, (mod, decl))
+ = lookupGlobalOccRn var `thenM` \ var_name ->
+ returnM (\vis_fn -> vis_fn var_name, (mod, decl))
-----------------------------------------------------
-- Loading Deprecations
-----------------------------------------------------
-loadDeprecs :: Module -> IfaceDeprecs -> RnM d Deprecations
-loadDeprecs m Nothing = returnRn NoDeprecs
-loadDeprecs m (Just (Left txt)) = returnRn (DeprecAll txt)
-loadDeprecs m (Just (Right prs)) = setModuleRn m $
- foldlRn loadDeprec emptyNameEnv prs `thenRn` \ env ->
- returnRn (DeprecSome env)
+loadDeprecs :: IfaceDeprecs -> RnM Deprecations
+loadDeprecs Nothing = returnM NoDeprecs
+loadDeprecs (Just (Left txt)) = returnM (DeprecAll txt)
+loadDeprecs (Just (Right prs)) = foldlM loadDeprec emptyNameEnv prs `thenM` \ env ->
+ returnM (DeprecSome env)
loadDeprec deprec_env (n, txt)
- = lookupIfaceName n `thenRn` \ name ->
- traceRn (text "Loaded deprecation(s) for" <+> ppr name <> colon <+> ppr txt) `thenRn_`
- returnRn (extendNameEnv deprec_env name (name,txt))
+ = lookupGlobalOccRn n `thenM` \ name ->
+-- traceRn (text "Loaded deprecation(s) for" <+> ppr name <> colon <+> ppr txt) `thenM_`
+ returnM (extendNameEnv deprec_env name (name,txt))
\end{code}
-%*********************************************************
+%********************************************************
%* *
-\subsection{Getting binders out of a declaration}
+ Load the ParsedIface for the *current* module
+ into a ModIface; then it can be checked
+ for up-to-date-ness
%* *
-%*********************************************************
-
-@getDeclBinders@ returns the names for a @RdrNameHsDecl@.
-It's used for both source code (from @availsFromDecl@) and interface files
-(from @loadDecl@).
-
-It doesn't deal with source-code specific things: @ValD@, @DefD@. They
-are handled by the sourc-code specific stuff in @RnNames@.
-
- *** See "THE NAMING STORY" in HsDecls ****
-
+%********************************************************
\begin{code}
-getTyClDeclBinders
- :: Module
- -> RdrNameTyClDecl
- -> RnM d (AvailInfo, [Name]) -- The [Name] are the system names
-
------------------
-getTyClDeclBinders mod (IfaceSig {tcdName = var, tcdLoc = src_loc})
- = newTopBinder mod var src_loc `thenRn` \ var_name ->
- returnRn (Avail var_name, [])
+loadOldIface :: ParsedIface -> RnM ModIface
+
+loadOldIface iface
+ = loadHomeDecls (pi_decls iface) `thenM` \ (decls_vers, new_decls) ->
+ loadHomeRules (pi_rules iface) `thenM` \ (rule_vers, new_rules) ->
+ loadHomeInsts (pi_insts iface) `thenM` \ new_insts ->
+ mappM loadHomeUsage (pi_usages iface) `thenM` \ usages ->
+ loadExports (pi_exports iface) `thenM` \ (export_vers, avails) ->
+ loadFixDecls (pi_fixity iface) `thenM` \ fix_env ->
+ loadDeprecs (pi_deprecs iface) `thenM` \ deprec_env ->
+
+ getModeRn `thenM` \ (InterfaceMode mod) ->
+ -- Caller sets the module before the call; also needed
+ -- by the newGlobalName stuff in some of the loadHomeX calls
+ let
+ version = VersionInfo { vers_module = pi_vers iface,
+ vers_exports = export_vers,
+ vers_rules = rule_vers,
+ vers_decls = decls_vers }
-getTyClDeclBinders mod (CoreDecl {tcdName = var, tcdLoc = src_loc})
- = newTopBinder mod var src_loc `thenRn` \ var_name ->
- returnRn (Avail var_name, [])
+ decls = mkIfaceDecls new_decls new_rules new_insts
-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)
+ mod_iface = ModIface { mi_module = mod, mi_package = pi_pkg iface,
+ 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,
+ mi_decls = decls,
+ mi_globals = Nothing
+ }
+ in
+ returnM mod_iface
+\end{code}
------------------
-new_top_bndrs mod names_w_locs
- = sequenceRn [newTopBinder mod name loc | (name,loc) <- names_w_locs]
+\begin{code}
+loadHomeDecls :: [(Version, RdrNameTyClDecl)]
+ -> RnM (NameEnv Version, [RenamedTyClDecl])
+loadHomeDecls decls = foldlM loadHomeDecl (emptyNameEnv, []) decls
+
+loadHomeDecl :: (NameEnv Version, [RenamedTyClDecl])
+ -> (Version, RdrNameTyClDecl)
+ -> RnM (NameEnv Version, [RenamedTyClDecl])
+loadHomeDecl (version_map, decls) (version, decl)
+ = rnTyClDecl decl `thenM` \ decl' ->
+ returnM (extendNameEnv version_map (tyClDeclName decl') version, decl':decls)
+
+------------------
+loadHomeRules :: (Version, [RdrNameRuleDecl])
+ -> RnM (Version, [RenamedRuleDecl])
+loadHomeRules (version, rules)
+ = mappM rnIfaceRuleDecl rules `thenM` \ rules' ->
+ returnM (version, rules')
+
+------------------
+loadHomeInsts :: [RdrNameInstDecl]
+ -> RnM [RenamedInstDecl]
+loadHomeInsts insts = mappM rnInstDecl insts
+
+------------------
+loadHomeUsage :: Usage OccName -> TcRn m (Usage Name)
+loadHomeUsage usage
+ = mappM rn_imp (usg_entities usage) `thenM` \ entities' ->
+ returnM (usage { usg_entities = entities' })
+ where
+ mod_name = usg_name usage
+ rn_imp (occ,vers) = newGlobalName2 mod_name occ `thenM` \ name ->
+ returnM (name,vers)
\end{code}
findAndReadIface :: SDoc -> ModuleName
-> IsBootInterface -- True <=> Look for a .hi-boot file
-- False <=> Look for .hi file
- -> RnM d (Either Message (Module, ParsedIface))
+ -> TcRn m (Either Message (Module, ParsedIface))
-- Nothing <=> file not found, or unreadable, or illegible
-- Just x <=> successfully found and parsed
+ -- It *doesn't* add an error to the monad, because
+ -- sometimes it's ok to fail... see notes with loadInterface
+
findAndReadIface doc_str mod_name hi_boot_file
- = traceRn trace_msg `thenRn_`
+ = traceRn trace_msg `thenM_`
-- Check for GHC.Prim, and return its static interface
if mod_name == gHC_PRIM_Name
- then returnRn (Right (gHC_PRIM, ghcPrimIface))
+ then returnM (Right (gHC_PRIM, ghcPrimIface))
else
- -- In interactive or --make mode, we are *not allowed* to demand-load
- -- a home package .hi file. So don't even look for them.
- -- This helps in the case where you are sitting in eg. ghc/lib/std
- -- and start up GHCi - it won't complain that all the modules it tries
- -- to load are found in the home location.
- ioToRnM_no_fail (readIORef v_GhcMode) `thenRn` \ mode ->
- let home_allowed = hi_boot_file || not (isCompManagerMode mode)
- in
-
- ioToRnM (if home_allowed
- then findModule mod_name
- else findPackageModule mod_name) `thenRn` \ maybe_found ->
+ ioToTcRn (findHiFile mod_name hi_boot_file) `thenM` \ maybe_found ->
case maybe_found of
+ Left files ->
+ traceRn (ptext SLIT("...not found")) `thenM_`
+ getDOpts `thenM` \ dflags ->
+ returnM (Left (noIfaceErr dflags mod_name hi_boot_file files))
- Right (Just (wanted_mod,locn))
- -> mkHiPath hi_boot_file locn `thenRn` \ file ->
- readIface file `thenRn` \ read_result ->
- case read_result of
- Left bad -> returnRn (Left bad)
- Right iface -> -- check that the module names agree
- let read_mod_name = pi_mod iface
- wanted_mod_name = moduleName wanted_mod
- in
- checkRn
- (wanted_mod_name == read_mod_name)
- (hiModuleNameMismatchWarn wanted_mod_name read_mod_name)
- `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))
+ Right (wanted_mod, file_path) ->
+ traceRn (ptext SLIT("readIFace") <+> text file_path) `thenM_`
+
+ readIface wanted_mod file_path hi_boot_file `thenM` \ read_result ->
+ -- Catch exceptions here
+
+ case read_result of
+ Left exn -> returnM (Left (badIfaceFile file_path
+ (text (showException exn))))
+
+ Right iface -> returnM (Right (wanted_mod, iface))
where
trace_msg = sep [hsep [ptext SLIT("Reading"),
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
+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
+ -- a home package .hi file. So don't even look for them.
+ -- This helps in the case where you are sitting in eg. ghc/lib/std
+ -- and start up GHCi - it won't complain that all the modules it tries
+ -- to load are found in the home location.
+ ghci_mode <- readIORef v_GhcMode ;
+ let { home_allowed = hi_boot_file ||
+ not (isCompManagerMode ghci_mode) } ;
+ maybe_found <- if home_allowed
+ then findModule mod_name
+ else findPackageModule mod_name ;
+
+ case maybe_found of {
+ Left files -> return (Left files) ;
+
+ 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_boot_path = replaceFilenameSuffix hi_path hiBootExt ;
+ hi_boot_ver_path = replaceFilenameSuffix hi_path hiBootVerExt
+ };
+
+ if not hi_boot_file then
+ return (Right (mod, hi_path))
+ else do {
+ hi_ver_exists <- doesFileExist hi_boot_ver_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 :: String -> RnM d (Either Message 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 file_path
- = --ioToRnM (putStrLn ("reading iface " ++ file_path)) `thenRn_`
- traceRn (ptext SLIT("readIFace") <+> text file_path) `thenRn_`
-
- let hi_boot_ver = "hi-boot-" ++ cHscIfaceFileVersion in
- if ".hi-boot" `isSuffixOf` file_path
- || hi_boot_ver `isSuffixOf` file_path then
-
- ioToRnM (hGetStringBuffer file_path) `thenRn` \ read_result ->
- case read_result of {
- Left io_error -> bale_out (text (show io_error));
- Right contents ->
- case parseIface contents (mkPState loc exts) of {
- POk _ iface -> returnRn (Right iface);
- PFailed err -> bale_out err
- }}
-
- else
- ioToRnM_no_fail (myTry (Binary.getBinFileWithDict file_path))
- `thenRn` \ either_iface ->
-
- case either_iface of
- Right iface -> returnRn (Right iface)
- Left (DynException d) | Just e <- fromDynamic d
- -> bale_out (text (show (e :: GhcException)))
-
- Left err -> bale_out (text (show err))
-
- where
+readIface mod file_path is_hi_boot_file
+ = ioToTcRn (tryMost (read_iface mod file_path is_hi_boot_file))
+
+read_iface mod file_path is_hi_boot_file
+ | is_hi_boot_file -- Read ascii
+ = do { buffer <- hGetStringBuffer file_path ;
+ case parseIface buffer (mkPState loc exts) of
+ POk _ iface | wanted_mod_name == actual_mod_name
+ -> return iface
+ | otherwise
+ -> throwDyn (ProgramError (showSDoc err))
+ -- 'showSDoc' is a bit yukky
+ where
+ wanted_mod_name = moduleName mod
+ actual_mod_name = pi_mod iface
+ err = hiModuleNameMismatchWarn wanted_mod_name actual_mod_name
+
+ PFailed err -> throwDyn (ProgramError (showSDoc err))
+ }
+
+ | otherwise -- Read binary
+ = readBinIface file_path
+
+ where
exts = ExtFlags {glasgowExtsEF = True,
ffiEF = True,
+ arrowsEF = True,
withEF = True,
parrEF = True}
loc = mkSrcLoc (mkFastString file_path) 1
-
- bale_out err = returnRn (Left (badIfaceFile file_path err))
-
-#if __GLASGOW_HASKELL__ < 501
-myTry = Exception.tryAllIO
-#else
-myTry = Exception.try
-#endif
\end{code}
+
%*********************************************************
-%* *
-\subsection{Looking up fixities}
-%* *
+%* *
+ Wired-in interface for GHC.Prim
+%* *
%*********************************************************
-@lookupFixityRn@ has to be in RnIfaces (or RnHiFiles), instead of
-its obvious home in RnEnv, 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
- = 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)
-
- 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,
- -- which exports a function 'f', thus;
- -- module CurrentModule where
- -- import A( f )
- -- module A( f ) where
- -- import B( f )
- -- Then B isn't loaded 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.
- loadHomeInterface doc name `thenRn` \ iface ->
- returnRn (lookupNameEnv (mi_fixities iface) name `orElse` defaultFixity)
- where
- doc = ptext SLIT("Checking fixity for") <+> ppr name
+ghcPrimIface :: ParsedIface
+ghcPrimIface = ParsedIface {
+ pi_mod = gHC_PRIM_Name,
+ 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)],
+ pi_fixity = [FixitySig (nameRdrName (idName seqId))
+ (Fixity 0 InfixR) noSrcLoc],
+ -- seq is infixr 0
+ pi_insts = [],
+ pi_rules = (1,[]),
+ pi_deprecs = Nothing
+ }
\end{code}
-
%*********************************************************
%* *
\subsection{Errors}
%*********************************************************
\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