\begin{code}
module RnHiFiles (
- findAndReadIface, loadInterface, loadHomeInterface,
- tryLoadInterface, loadOrphanModules,
- loadExports, loadFixDecls, loadDeprecs,
-
- lookupFixityRn,
-
- getTyClDeclBinders,
- removeContext -- removeContext probably belongs somewhere else
+ readIface, loadInterface, loadHomeInterface,
+ loadOrphanModules,
+ loadOldIface,
+ ParsedIface(..)
) where
#include "HsVersions.h"
+import DriverState ( v_GhcMode, isCompManagerMode )
+import DriverUtil ( replaceFilenameSuffix )
import CmdLineOpts ( opt_IgnoreIfacePragmas )
-import HscTypes
-import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..),
- HsType(..), ConDecl(..),
- FixitySig(..), RuleDecl(..),
- tyClDeclNames
- )
-import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl,
- extractHsTyRdrNames
+import Parser ( parseIface )
+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(..), ConDecl(..),
+ hsTyVarNames, splitHsInstDeclTy, tyClDeclName, tyClDeclNames
)
-import BasicTypes ( Version, defaultFixity )
+import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl )
+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 ParseIface ( parseIface, IfaceStuff(..) )
+import TcRnMonad
-import Name ( Name {-instance NamedThing-}, nameOccName,
- nameModule, isLocallyDefined,
- NamedThing(..),
- mkNameEnv, extendNameEnv
- )
-import Module ( Module,
- moduleName, isModuleInThisPackage,
- ModuleName, WhereFrom(..),
- extendModuleEnv, lookupModuleEnvByName,
- )
-import RdrName ( RdrName, rdrNameOcc )
+import PrelNames ( gHC_PRIM_Name, gHC_PRIM )
+import PrelInfo ( ghcPrimExports, cCallableClassDecl, cReturnableClassDecl )
+import Name ( Name {-instance NamedThing-},
+ nameModule, isInternalName )
+import NameEnv
import NameSet
-import SrcLoc ( mkSrcLoc, SrcLoc )
-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 )
+import Finder ( findModule, findPackageModule,
+ hiBootExt, hiBootVerExt )
import Lex
import FiniteMap
+import ListSetOps ( minusList )
import Outputable
import Bag
+import BinIface ( readBinIface )
+import Panic
+
+import EXCEPTION as Exception
+import DATA_IOREF ( readIORef )
+
+import Directory
\end{code}
%*********************************************************
\begin{code}
-loadHomeInterface :: SDoc -> Name -> RnM d Ifaces
+loadHomeInterface :: SDoc -> Name -> TcRn m ModIface
loadHomeInterface doc_str name
- = loadInterface doc_str (moduleName (nameModule name)) ImportBySystem
+ = 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 Ifaces
-loadInterface doc mod from
- = tryLoadInterface doc mod from `thenRn` \ (ifaces, maybe_err) ->
- case maybe_err of
- Nothing -> returnRn ifaces
- Just err -> failWithRn ifaces err
-
-tryLoadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d (Ifaces, Maybe Message)
- -- Returns (Just err) if an error happened
- -- 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 ->
- getIfacesRn `thenRn` \ ifaces ->
-
- -- Check whether we have it already in the home package
- case lookupModuleEnvByName hit mod_name of {
- Just _ -> returnRn (ifaces, Nothing) ; -- In the home package
- Nothing ->
+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.
+
+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 hpt pit mod_name of {
+ Just iface | case from of
+ 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
+ -- before we got to real imports.
+ 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
- (ImportBySystem, Just (_, is_boot, _)) -> is_boot --
- (ImportBySystem, Nothing) -> False
+ (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
-- nothing about, so we assume it's from
-- another package, where we aren't doing
redundant_source_import
= case (from, mod_info) of
- (ImportByUserSource, Just (_,False,_)) -> True
- other -> False
+ (ImportByUser True, Just (_, False)) -> True
+ other -> False
in
- -- CHECK WHETHER WE HAVE IT ALREADY
- case mod_info of {
- Just (_, _, True)
- -> -- We're read it already so don't re-read it
- returnRn (ifaces, Nothing) ;
-
- _ ->
-- 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 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 ->
+ findAndReadIface doc_str mod_name hi_boot_file
+ `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
- new_mod_map = addToFM mod_map mod_name (False, False, True)
- new_ifaces = ifaces { iImpModInfo = new_mod_map }
- in
- setIfacesRn new_ifaces `thenRn_`
- returnRn (new_ifaces, 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).
-- about, it should be from a different package to this one
WARN( not (maybeToBool mod_info) &&
case from of { ImportBySystem -> True; other -> False } &&
- isModuleInThisPackage mod,
+ 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) ->
- foldlRn (loadInstDecl 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.
- mod_map1 = case from of
- ImportByUser -> addModDeps mod (pi_usages iface) mod_map
- other -> mod_map
- mod_map2 = addToFM mod_map1 mod_name (has_orphans, hi_boot_file, True)
-
-- 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 (iPIT ifaces) mod mod_iface
- mod_iface = ModIface { mi_module = mod, mi_version = version,
- mi_exports = avails, mi_orphan = has_orphans,
+ new_pit = extendModuleEnv pit mod mod_iface
+ mod_iface = ModIface { mi_module = mod, mi_package = pi_pkg iface,
+ mi_version = version,
+ 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 = panic "No mi_globals in PIT"
+ 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 (new_ifaces, Nothing)
- }}}
-
------------------------------------------------------
--- Adding module dependencies from the
--- import decls in the interface file
------------------------------------------------------
-
-addModDeps :: Module -> [ImportVersion a]
- -> ImportedModuleInfo -> ImportedModuleInfo
--- (addModDeps M ivs deps)
--- We are importing module M, and M.hi contains 'import' decls given by ivs
-addModDeps mod 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, IsLoaded))]
- filtered_new_deps
- | isModuleInThisPackage mod
- = [ (imp_mod, (has_orphans, is_boot, False))
- | (imp_mod, has_orphans, is_boot, _) <- new_deps
- ]
- | otherwise = [ (imp_mod, (True, False, False))
- | (imp_mod, has_orphans, _, _) <- new_deps,
- has_orphans
- ]
- add (imp_mod, dep) deps = addToFM_C combine deps imp_mod dep
-
- combine old@(_, old_is_boot, old_is_loaded) new
- | old_is_loaded || not old_is_boot = old -- Keep the old info if it's already loaded
- -- or if it's a non-boot pending load
- | otherwise = new -- Otherwise pick new info
-
+ setEps new_eps `thenM_`
+ returnM mod_iface
+ }}
-----------------------------------------------------
-- Loading the export list
-----------------------------------------------------
-loadExports :: (Version, [ExportItem]) -> RnM d (Version, [(ModuleName,Avails)])
+loadExports :: (Version, [RdrExportItem]) -> TcRn m (Version, [(ModuleName,Avails)])
loadExports (vers, items)
- = getModuleRn `thenRn` \ this_mod ->
- mapRn (loadExport this_mod) items `thenRn` \ avails_s ->
- returnRn (vers, avails_s)
-
-
-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!
+ = mappM loadExport items `thenM` \ avails_s ->
+ returnM (vers, avails_s)
- | otherwise
- = mapRn (load_entity mod) entities `thenRn` \ avails ->
- returnRn (mod, avails)
- where
- new_name mod occ = newGlobalName mod occ
+loadExport :: RdrExportItem -> TcRn m (ModuleName, Avails)
+loadExport (mod, entities)
+ = mappM (load_entity mod) entities `thenM` \ avails ->
+ returnM (mod, avails)
+ where
load_entity mod (Avail occ)
- = new_name mod occ `thenRn` \ name ->
- returnRn (Avail name)
+ = newGlobalName2 mod occ `thenM` \ name ->
+ returnM (Avail name)
load_entity mod (AvailTC occ occs)
- = new_name mod occ `thenRn` \ name ->
- mapRn (new_name 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)
-loadDecls mod decls_map decls
- = foldlRn (loadDecl mod) (emptyNameEnv, decls_map) decls
-
-loadDecl :: Module
- -> (NameEnv Version, DeclsMap)
- -> (Version, RdrNameTyClDecl)
- -> RnM d (NameEnv Version, DeclsMap)
+ -> TcRn m (NameEnv Version, DeclsMap)
+loadDecls mod (decls_map, n_slurped) decls
+ = 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)
- = getIfaceDeclBinders new_name decl `thenRn` \ full_avail ->
+ = getTyClDeclBinders mod decl `thenM` \ avail ->
+ getSysBinders mod decl `thenM` \ sys_names ->
let
+ full_avail = case avail of
+ Avail n -> avail
+ AvailTC n ns -> AvailTC n (sys_names ++ ns)
main_name = availName full_avail
new_decls_map = extendNameEnvList decls_map stuff
stuff = [ (name, (full_avail, name==main_name, (mod, decl)))
new_version_map = extendNameEnv version_map main_name version
in
- 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
- -- newTopBinder puts into the cache the binder with the
- -- module information set correctly. When the decl is later renamed,
- -- the binding site will thereby get the correct module.
- -- There maybe occurrences that don't have the correct Module, but
- -- by the typechecker will propagate the binding definition to all
- -- the occurrences, so that doesn't matter
- new_name rdr_name loc = newTopBinder mod rdr_name loc
+ -- 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 sig@(FixitySig rdr_name fixity loc)
- = 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
-----------------------------------------------------
-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 IfaceInsts
+loadInstDecls mod (insts, n_slurped) decls
+ = foldlM (loadInstDecl mod) insts decls `thenM` \ insts' ->
+ returnM (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.
--
-- instance Foo a => Baz (T a) where ...
--
-- Here the gates are Baz and T, but *not* Foo.
+ --
+ -- HOWEVER: functional dependencies make things more complicated
+ -- class C a b | a->b where ...
+ -- instance C Foo Baz where ...
+ -- Here, the gates are really only C and Foo, *not* Baz.
+ -- That is, if C and Foo are visible, even if Baz isn't, we must
+ -- slurp the decl.
+ --
+ -- Rather than take fundeps into account "properly", we just slurp
+ -- if C is visible and *any one* of the Names in the types
+ -- This is a slightly brutal approximation, but most instance decls
+ -- are regular H98 ones and it's perfect for them.
+ --
+ -- 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 (,).
+ rnHsType (text "In an interface instance decl") inst_ty `thenM` \ inst_ty' ->
let
- munged_inst_ty = removeContext inst_ty
- free_names = extractHsTyRdrNames munged_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
- setModuleRn mod $
- mapRn lookupOrigName free_names `thenRn` \ gate_names ->
- returnRn ((mkNameSet gate_names, (mod, InstD decl)) `consBag` insts)
+-- traceRn ((text "Load instance for" <+> ppr inst_ty') $$ ppr free_tcs) `thenM_`
+ returnM ((gate_fn, (mod, decl)) `consBag` insts)
--- In interface files, the instance decls now look like
--- forall a. Foo a -> Baz (T a)
--- so we have to strip off function argument types as well
--- as the bit before the '=>' (which is always empty in interface files)
-removeContext (HsForAllTy tvs cxt ty) = HsForAllTy tvs [] (removeFuns ty)
-removeContext ty = removeFuns ty
-
-removeFuns (HsFunTy _ ty) = removeFuns ty
-removeFuns ty = ty
-
-----------------------------------------------------
-- Loading Rules
-----------------------------------------------------
-loadRules :: Module -> IfaceRules
+loadRules :: Module
+ -> IfaceRules
-> (Version, [RdrNameRuleDecl])
- -> RnM d (Version, IfaceRules)
-loadRules mod rule_bag (version, rules)
+ -> RnM (Version, IfaceRules)
+loadRules mod (rule_bag, n_slurped) (version, rules)
| null rules || opt_IgnoreIfacePragmas
- = returnRn (version, rule_bag)
+ = returnM (version, (rule_bag, n_slurped))
| otherwise
- = setModuleRn mod $
- mapRn (loadRule mod) rules `thenRn` \ new_rules ->
- returnRn (version, rule_bag `unionBags` listToBag new_rules)
+ = mappM (loadRule mod) rules `thenM` \ new_rules ->
+ returnM (version, (rule_bag `unionBags` listToBag new_rules, n_slurped))
-loadRule :: Module -> RdrNameRuleDecl -> RnM d GatedDecl
+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)
- = lookupOrigName var `thenRn` \ var_name ->
- returnRn (unitNameSet var_name, (mod, RuleD decl))
+loadRule mod decl@(IfaceRule _ _ _ var _ _ src_loc)
+ = 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)
- = lookupOrigName 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@.
+%********************************************************
\begin{code}
-getIfaceDeclBinders, getTyClDeclBinders
- :: (RdrName -> SrcLoc -> RnM d Name) -- New-name function
- -> RdrNameTyClDecl
- -> RnM d AvailInfo
-
-getIfaceDeclBinders new_name tycl_decl
- = getTyClDeclBinders new_name tycl_decl `thenRn` \ avail ->
- getSysTyClDeclBinders new_name 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 new_name (IfaceSig var ty prags src_loc)
- = new_name var src_loc `thenRn` \ var_name ->
- returnRn (Avail var_name)
-
-getTyClDeclBinders new_name tycl_decl
- = mapRn do_one (tyClDeclNames tycl_decl) `thenRn` \ (main_name:sub_names) ->
- returnRn (AvailTC main_name (main_name : sub_names))
- where
- do_one (name,loc) = new_name name loc
-\end{code}
+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 }
-@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.
+ decls = mkIfaceDecls new_decls new_rules new_insts
-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.
+ 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}
\begin{code}
-getSysTyClDeclBinders new_name (ClassDecl _ cname _ _ sigs _ names src_loc)
- = sequenceRn [new_name n src_loc | n <- names]
-
-getSysTyClDeclBinders new_name (TyData _ _ _ _ cons _ _ _ _ _)
- = sequenceRn [new_name wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons]
-
-getSysTyClDeclBinders new_name other_decl
- = returnRn []
+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}
-
%*********************************************************
%* *
\subsection{Reading an interface file}
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_`
- ioToRnM (findModule mod_name) `thenRn` \ maybe_found ->
+ = traceRn trace_msg `thenM_`
+
+ -- Check for GHC.Prim, and return its static interface
+ if mod_name == gHC_PRIM_Name
+ then returnM (Right (gHC_PRIM, ghcPrimIface))
+ else
+
+ ioToTcRn (findHiFile mod_name hi_boot_file) `thenM` \ maybe_found ->
case maybe_found of
- Right (Just (mod,locn))
- | hi_boot_file -> readIface mod (hi_file locn ++ "-boot")
- | otherwise -> readIface mod (hi_file locn)
-
- -- Can't find it
- other -> traceRn (ptext SLIT("...not found")) `thenRn_`
- returnRn (Left (noIfaceErr mod_name hi_boot_file))
+ Left files ->
+ traceRn (ptext SLIT("...not found")) `thenM_`
+ getDOpts `thenM` \ dflags ->
+ returnM (Left (noIfaceErr dflags mod_name hi_boot_file files))
+
+ 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"),
ptext SLIT("interface for"),
ppr mod_name <> semi],
nest 4 (ptext SLIT("reason:") <+> doc_str)]
+
+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 :: Module -> String -> RnM d (Either Message (Module, 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 wanted_mod file_path
- = traceRn (ptext SLIT("...reading from") <+> text file_path) `thenRn_`
- ioToRnM (hGetStringBuffer False file_path) `thenRn` \ read_result ->
- case read_result of
- Right contents ->
- case parseIface contents
- PState{ bol = 0#, atbol = 1#,
- context = [],
- glasgow_exts = 1#,
- loc = mkSrcLoc (mkFastString file_path) 1 } of
- POk _ (PIface iface) ->
- warnCheckRn (wanted_mod == read_mod)
- (hiModuleNameMismatchWarn wanted_mod read_mod) `thenRn_`
- returnRn (Right (wanted_mod, iface))
- where
- read_mod = pi_mod 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.
-
- Left io_err -> bale_out (text (show io_err))
- where
- bale_out err = returnRn (Left (badIfaceFile file_path err))
+
+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
\end{code}
%*********************************************************
-%* *
-\subsection{Looking up fixities}
-%* *
+%* *
+ Wired-in interface for GHC.Prim
+%* *
%*********************************************************
-This has to be in RnIfaces (or RnHiFiles) because it calls loadHomeInterface
-
\begin{code}
-lookupFixityRn :: Name -> RnMS Fixity
-lookupFixityRn name
- | isLocallyDefined name
- = getFixityEnv `thenRn` \ local_fix_env ->
- returnRn (lookupLocalFixity local_fix_env name)
-
- | otherwise -- 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', which is defined in module B. 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.
- = getHomeIfaceTableRn `thenRn` \ hit ->
- loadHomeInterface doc name `thenRn` \ ifaces ->
- case lookupTable hit (iPIT ifaces) name of
- Just iface -> returnRn (lookupNameEnv (mi_fixities iface) name `orElse` defaultFixity)
- Nothing -> returnRn 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]
-hiModuleNameMismatchWarn :: Module -> Module -> Message
+hiModuleNameMismatchWarn :: ModuleName -> ModuleName -> Message
hiModuleNameMismatchWarn requested_mod read_mod =
hsep [ ptext SLIT("Something is amiss; requested module name")
- , ppr (moduleName requested_mod)
+ , ppr requested_mod
, ptext SLIT("differs from name found in the interface file")
, ppr read_mod
]
warnRedundantSourceImport mod_name
= ptext SLIT("Unnecessary {- SOURCE -} in the import of module")
<+> quotes (ppr mod_name)
-\end{code}
+warnSelfImport mod
+ = ptext SLIT("Importing my own interface: module") <+> ppr mod
+\end{code}
projects / ghc-hetmet.git / blobdiff