getInterfaceExports,
getImportedInstDecls, getImportedRules,
lookupFixityRn, loadHomeInterface,
- importDecl, ImportDeclResult(..), recordLocalSlurps, loadBuiltinRules,
- mkImportExportInfo, getSlurped,
+ importDecl, ImportDeclResult(..), recordLocalSlurps,
+ mkImportInfo, getSlurped,
getDeclBinders, getDeclSysBinders,
removeContext -- removeContext probably belongs somewhere else
#include "HsVersions.h"
import CmdLineOpts ( opt_NoPruneDecls, opt_NoPruneTyDecls, opt_IgnoreIfacePragmas )
+import HscTypes
import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), IfaceSig(..),
- HsType(..), ConDecl(..), IE(..), ConDetails(..), Sig(..),
+ HsType(..), ConDecl(..),
ForeignDecl(..), ForKind(..), isDynamicExtName,
FixitySig(..), RuleDecl(..),
- isClassOpSig, DeprecDecl(..)
+ tyClDeclNames
)
-import HsImpExp ( ieNames )
-import CoreSyn ( CoreRule )
+import HsImpExp ( ImportDecl(..) )
import BasicTypes ( Version, defaultFixity )
import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl, RdrNameRuleDecl,
- RdrNameDeprecation, RdrNameIE,
extractHsTyRdrNames
)
import RnEnv
NamedThing(..),
mkNameEnv, elemNameEnv, extendNameEnv
)
-import Module ( Module,
+import Module ( Module, ModuleEnv,
moduleName, isModuleInThisPackage,
ModuleName, WhereFrom(..),
- extendModuleEnv, lookupModuleEnv, lookupModuleEnvByName
+ emptyModuleEnv, extendModuleEnv, lookupModuleEnvByName,
+ extendModuleEnv_C, lookupWithDefaultModuleEnv
)
import RdrName ( RdrName, rdrNameOcc )
import NameSet
import SrcLoc ( mkSrcLoc, SrcLoc )
-import PrelInfo ( cCallishTyKeys, wiredInThingEnv )
+import PrelInfo ( wiredInThingEnv )
import Maybes ( maybeToBool, orElse )
import StringBuffer ( hGetStringBuffer )
import FastString ( mkFastString )
import ErrUtils ( Message )
-import Util ( sortLt )
import Lex
import FiniteMap
import Outputable
import Bag
-import HscTypes
-import List ( nub )
+import List ( nub )
\end{code}
tryLoadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d (Ifaces, Maybe Message)
-- Returns (Just err) if an error happened
- -- Guarantees to return with iImpModInfo m --> (... Just cts)
- -- (If the load fails, we plug in a vanilla placeholder
+ -- Guarantees to return with iImpModInfo m --> (..., True)
+ -- (If the load fails, we plug in a vanilla placeholder)
tryLoadInterface doc_str mod_name from
- = getIfacesRn `thenRn` \ ifaces ->
+ = 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 ->
+
let
mod_map = iImpModInfo ifaces
mod_info = lookupFM mod_map mod_name
loadDecls mod (iDecls ifaces) (pi_decls iface) `thenRn` \ (decls_vers, new_decls) ->
loadRules mod (iRules ifaces) (pi_rules iface) `thenRn` \ (rule_vers, new_rules) ->
- loadFixDecls mod_name (pi_fixity iface) `thenRn` \ (fix_vers, fix_env) ->
- foldlRn (loadDeprec mod) emptyNameEnv (pi_deprecs iface) `thenRn` \ deprec_env ->
+ loadFixDecls mod_name (pi_fixity iface) `thenRn` \ fix_env ->
+ loadDeprecs mod (pi_deprecs iface) `thenRn` \ deprec_env ->
foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts ->
- loadExports (pi_exports iface) `thenRn` \ avails ->
+ loadExports (pi_exports iface) `thenRn` \ (export_vers, avails) ->
let
- version = VersionInfo { modVers = pi_vers iface,
- fixVers = fix_vers,
- ruleVers = rule_vers,
- declVers = decls_vers }
+ 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
in
setIfacesRn new_ifaces `thenRn_`
returnRn (new_ifaces, Nothing)
- }}
+ }}}
-----------------------------------------------------
-- Adding module dependencies from the
-- 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 :: [(ModuleName, (WhetherHasOrphans, IsBootInterface, IsLoaded))]
filtered_new_deps
| isModuleInThisPackage mod
= [ (imp_mod, (has_orphans, is_boot, False))
-- Loading the export list
-----------------------------------------------------
-loadExports :: [ExportItem] -> RnM d Avails
-loadExports items
+loadExports :: (Version, [ExportItem]) -> RnM d (Version, Avails)
+loadExports (vers, items)
= getModuleRn `thenRn` \ this_mod ->
mapRn (loadExport this_mod) items `thenRn` \ avails_s ->
- returnRn (concat avails_s)
+ returnRn (vers, concat avails_s)
loadExport :: Module -> ExportItem -> RnM d [AvailInfo]
-- Loading fixity decls
-----------------------------------------------------
-loadFixDecls mod_name (version, decls)
+loadFixDecls mod_name decls
= mapRn (loadFixDecl mod_name) decls `thenRn` \ to_add ->
- returnRn (version, mkNameEnv to_add)
+ returnRn (mkNameEnv to_add)
loadFixDecl mod_name sig@(FixitySig rdr_name fixity loc)
= newGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name ->
= lookupOrigName var `thenRn` \ var_name ->
returnRn (unitNameSet var_name, (mod, RuleD decl))
-loadBuiltinRules :: [(RdrName, CoreRule)] -> RnMG ()
-loadBuiltinRules builtin_rules
- = getIfacesRn `thenRn` \ ifaces ->
- mapRn loadBuiltinRule builtin_rules `thenRn` \ rule_decls ->
- setIfacesRn (ifaces { iRules = iRules ifaces `unionBags` listToBag rule_decls })
-
-loadBuiltinRule (var, rule)
- = lookupOrigName var `thenRn` \ var_name ->
- returnRn (unitNameSet var_name, (nameModule var_name, RuleD (IfaceRuleOut var rule)))
-
-----------------------------------------------------
-- Loading Deprecations
-----------------------------------------------------
-loadDeprec :: Module -> DeprecationEnv -> RdrNameDeprecation -> RnM d DeprecationEnv
-loadDeprec mod deprec_env (Deprecation (IEModuleContents _) txt _)
- = traceRn (text "module deprecation not yet implemented:" <+> ppr mod <> colon <+> ppr txt) `thenRn_`
- -- SUP: TEMPORARY HACK, ignoring module deprecations for now
- returnRn deprec_env
-
-loadDeprec mod deprec_env (Deprecation ie txt _)
- = setModuleRn mod $
- mapRn lookupOrigName (ieNames ie) `thenRn` \ names ->
- traceRn (text "loaded deprecation(s) for" <+> hcat (punctuate comma (map ppr names)) <> colon <+> ppr txt) `thenRn_`
- returnRn (extendNameEnvList deprec_env (zip names (repeat txt)))
+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)
+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 txt)
\end{code}
case lookupNameEnv (iDecls ifaces) needed_name of
{- OMIT DEFERRED STUFF FOR NOW, TILL GHCI WORKS
- Just (version, avail, is_tycon_name, decl@(_, TyClD (TyData DataType _ _ _ _ ncons _ _ _ _ _)))
+ Just (version, avail, is_tycon_name, decl@(_, TyClD (TyData DataType _ _ _ _ ncons _ _ _ _)))
-- This case deals with deferred import of algebraic data types
| not opt_NoPruneTyDecls
-- 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` \ hst ->
- case lookupFixityEnv hst name of {
- Just fixity -> returnRn fixity ;
- Nothing ->
-
+ = getHomeIfaceTableRn `thenRn` \ hit ->
loadHomeInterface doc name `thenRn` \ ifaces ->
- returnRn (lookupFixityEnv (iPIT ifaces) name `orElse` defaultFixity)
- }
+ 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
\end{code}
So we'll get an early bale-out when compiling A if B's version changes.
\begin{code}
-mkImportExportInfo :: ModuleName -- Name of this module
- -> Avails -- Info about exports
- -> [ImportDecl n] -- The import decls
- -> RnMG ([ExportItem], -- Export info for iface file; sorted
- [ImportVersion Name]) -- Import info for iface file; sorted
- -- Both results are sorted into canonical order to
- -- reduce needless wobbling of interface files
-
-mkImportExportInfo this_mod export_avails exports
+mkImportInfo :: ModuleName -- Name of this module
+ -> [ImportDecl n] -- The import decls
+ -> RnMG [ImportVersion Name]
+
+mkImportInfo this_mod imports
= getIfacesRn `thenRn` \ ifaces ->
+ getHomeIfaceTableRn `thenRn` \ hit ->
let
import_all_mods :: [ModuleName]
-- Modules where we imported all the names
-- (apart from hiding some, perhaps)
- import_all_mods = nub [ m | ImportDecl m _ _ _ imp_list _ <- imports ]
+ import_all_mods = nub [ m | ImportDecl m _ _ _ imp_list _ <- imports,
+ import_all imp_list ]
import_all (Just (False, _)) = False -- Imports are specified explicitly
import_all other = True -- Everything is imported
mod_map = iImpModInfo ifaces
imp_names = iVSlurp ifaces
+ pit = iPIT ifaces
-- mv_map groups together all the things imported from a particular module.
mv_map :: ModuleEnv [Name]
- mv_map = foldr add_mv emptyFM imp_names
+ mv_map = foldr add_mv emptyModuleEnv imp_names
- add_mv (name, version) mv_map = addItem mv_map (nameModule name) name
+ add_mv name mv_map = addItem mv_map (nameModule name) name
-- Build the result list by adding info for each module.
-- For (a) a library module, we don't record it at all unless it contains orphans
so_far
| not opened -- We didn't even open the interface
- -> -- This happens when a module, Foo, that we explicitly imported has
+ = -- This happens when a module, Foo, that we explicitly imported has
-- 'import Baz' in its interface file, recording that Baz is below
-- Foo in the module dependency hierarchy. We want to propagate this
-- information. The Nothing says that we didn't even open the interface
- -- file but we must still propagate the dependeny info.
+ -- file but we must still propagate the dependency info.
-- The module in question must be a local module (in the same package)
go_for_it NothingAtAll
| is_lib_module && not has_orphans
- -> so_far
+ = so_far
- | is_lib_module -- Record the module version only
- -> go_for_it (Everything mod_vers)
+ | is_lib_module -- Record the module version only
+ = go_for_it (Everything module_vers)
- | otherwise
- -> go_for_it (mk_whats_imported mod mod_vers)
+ | otherwise
+ = go_for_it whats_imported
- where
-
where
go_for_it exports = (mod_name, has_orphans, is_boot, exports) : so_far
mod_iface = lookupIface hit pit mod_name
is_lib_module = not (isModuleInThisPackage mod)
version_info = mi_version mod_iface
version_env = vers_decls version_info
+ module_vers = vers_module version_info
- whats_imported = Specifically mod_vers export_vers import_items
+ whats_imported = Specifically module_vers
+ export_vers import_items
(vers_rules version_info)
import_items = [(n,v) | n <- lookupWithDefaultModuleEnv mv_map [] mod,
- let v = lookupNameEnv version_env `orElse`
+ let v = lookupNameEnv version_env n `orElse`
pprPanic "mk_whats_imported" (ppr n)
]
- export_vers | moduleName mod `elem` import_all_mods = Just (vers_exports version_info)
- | otherwise = Nothing
+ export_vers | moduleName mod `elem` import_all_mods
+ = Just (vers_exports version_info)
+ | otherwise
+ = Nothing
import_info = foldFM mk_imp_info [] mod_map
-
- -- Sort exports into groups by module
- export_fm :: FiniteMap Module [RdrAvailInfo]
- export_fm = foldr insert emptyFM export_avails
-
- insert avail efm = addItem efm (nameModule (availName avail))
- avail
-
- export_info = fmToList export_fm
in
traceRn (text "Modules in Ifaces: " <+> fsep (map ppr (keysFM mod_map))) `thenRn_`
- returnRn (export_info, import_info)
+ returnRn import_info
addItem :: ModuleEnv [a] -> Module -> a -> ModuleEnv [a]
-addItem fm mod x = plusModuleEnv_C add_item fm mod [x]
+addItem fm mod x = extendModuleEnv_C add_item fm mod [x]
where
add_item xs _ = x:xs
\end{code}
-> RdrNameHsDecl
-> RnM d (Maybe AvailInfo)
-getDeclBinders new_name (TyClD (TyData _ _ tycon _ condecls _ _ _ src_loc _ _))
- = new_name tycon src_loc `thenRn` \ tycon_name ->
- getConFieldNames new_name condecls `thenRn` \ sub_names ->
- returnRn (Just (AvailTC tycon_name (tycon_name : nub sub_names)))
- -- The "nub" is because getConFieldNames can legitimately return duplicates,
- -- when a record declaration has the same field in multiple constructors
-
-getDeclBinders new_name (TyClD (TySynonym tycon _ _ src_loc))
- = new_name tycon src_loc `thenRn` \ tycon_name ->
- returnRn (Just (AvailTC tycon_name [tycon_name]))
-
-getDeclBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ _ src_loc))
- = new_name cname src_loc `thenRn` \ class_name ->
-
- -- Record the names for the class ops
- let
- -- just want class-op sigs
- op_sigs = filter isClassOpSig sigs
- in
- mapRn (getClassOpNames new_name) op_sigs `thenRn` \ sub_names ->
-
- returnRn (Just (AvailTC class_name (class_name : sub_names)))
+getDeclBinders new_name (TyClD tycl_decl)
+ = mapRn do_one (tyClDeclNames tycl_decl) `thenRn` \ (main_name:sub_names) ->
+ returnRn (Just (AvailTC main_name (main_name : sub_names)))
+ where
+ do_one (name,loc) = new_name name loc
getDeclBinders new_name (SigD (IfaceSig var ty prags src_loc))
= new_name var src_loc `thenRn` \ var_name ->
returnRn (Just (Avail var_name))
-getDeclBinders new_name (FixD _) = returnRn Nothing
-getDeclBinders new_name (DeprecD _) = returnRn Nothing
-
-- foreign declarations
getDeclBinders new_name (ForD (ForeignDecl nm kind _ dyn _ loc))
| binds_haskell_name kind dyn
= lookupOrigName nm `thenRn_`
returnRn Nothing
-getDeclBinders new_name (DefD _) = returnRn Nothing
-getDeclBinders new_name (InstD _) = returnRn Nothing
-getDeclBinders new_name (RuleD _) = returnRn Nothing
+getDeclBinders new_name (FixD _) = returnRn Nothing
+getDeclBinders new_name (DeprecD _) = returnRn Nothing
+getDeclBinders new_name (DefD _) = returnRn Nothing
+getDeclBinders new_name (InstD _) = returnRn Nothing
+getDeclBinders new_name (RuleD _) = returnRn Nothing
binds_haskell_name (FoImport _) _ = True
binds_haskell_name FoLabel _ = True
binds_haskell_name FoExport ext_nm = isDynamicExtName ext_nm
-
-----------------
-getConFieldNames new_name (ConDecl con _ _ _ (RecCon fielddecls) src_loc : rest)
- = mapRn (\n -> new_name n src_loc) (con:fields) `thenRn` \ cfs ->
- getConFieldNames new_name rest `thenRn` \ ns ->
- returnRn (cfs ++ ns)
- where
- fields = concat (map fst fielddecls)
-
-getConFieldNames new_name (ConDecl con _ _ _ condecl src_loc : rest)
- = new_name con src_loc `thenRn` \ n ->
- getConFieldNames new_name rest `thenRn` \ ns ->
- returnRn (n : ns)
-
-getConFieldNames new_name [] = returnRn []
-
-getClassOpNames new_name (ClassOpSig op _ _ src_loc) = new_name op src_loc
\end{code}
@getDeclSysBinders@ gets the implicit binders introduced by a decl.
bindings of their own elsewhere.
\begin{code}
-getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ names
- src_loc))
+getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ names src_loc))
= sequenceRn [new_name n src_loc | n <- names]
-getDeclSysBinders new_name (TyClD (TyData _ _ _ _ cons _ _ _ _ _ _))
+getDeclSysBinders new_name (TyClD (TyData _ _ _ _ cons _ _ _ _ _))
= sequenceRn [new_name wkr_name src_loc | ConDecl _ wkr_name _ _ _ src_loc <- cons]
getDeclSysBinders new_name other_decl
ioToRnM (finder mod_name) `thenRn` \ maybe_found ->
case maybe_found of
- Just (mod,locn)
+ Right (Just (mod,locn))
| hi_boot_file -> readIface mod (hi_file locn ++ "-hi-boot")
| otherwise -> readIface mod (hi_file locn)
= ptext SLIT("Unnecessary {- SOURCE -} in the import of module")
<+> quotes (ppr mod_name)
-hiModuleNameMismatchWarn :: Module -> ModuleName -> Message
+hiModuleNameMismatchWarn :: Module -> Module -> Message
hiModuleNameMismatchWarn requested_mod read_mod =
hsep [ ptext SLIT("Something is amiss; requested module name")
, ppr (moduleName requested_mod)
projects / ghc-hetmet.git / blobdiff