-import List ( nub )
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Loading a new interface file}
-%* *
-%*********************************************************
-
-\begin{code}
-loadHomeInterface :: SDoc -> Name -> RnM d Ifaces
-loadHomeInterface doc_str name
- = loadInterface doc_str (moduleName (nameModule name)) ImportBySystem
-
-loadOrphanModules :: [ModuleName] -> RnM d ()
-loadOrphanModules mods
- | null mods = returnRn ()
- | otherwise = traceRn (text "Loading orphan modules:" <+>
- fsep (map pprModuleName mods)) `thenRn_`
- mapRn_ load mods `thenRn_`
- returnRn ()
- where
- load mod = loadInterface (mk_doc mod) mod ImportBySystem
- mk_doc mod = pprModuleName 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 --> (... Just cts)
- -- (If the load fails, we plug in a vanilla placeholder
-tryLoadInterface doc_str mod_name from
- = getIfacesRn `thenRn` \ ifaces ->
- let
- mod_map = iImpModInfo ifaces
- mod_info = lookupFM mod_map mod_name
-
- hi_boot_file = case from of {
- ImportByUser -> False ; -- Not hi-boot
- ImportByUserSource -> True ; -- hi-boot
- ImportBySystem ->
- case mod_info of
- Just (_, is_boot, _) -> is_boot
-
- 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
- -- dependency tracking. So it won't be a hi-boot file.
- }
- redundant_source_import
- = case (from, mod_info) of
- (ImportByUserSource, Just (_,False,_)) -> True
- other -> False
- in
- -- CHECK WHETHER WE HAVE IT ALREADY
- case mod_info of {
- Just (_, _, Just _)
- -> -- 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_`
-
- -- READ THE MODULE IN
- findAndReadIface doc_str mod_name hi_boot_file `thenRn` \ 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
- mod = mkVanillaModule mod_name
- new_mod_map = addToFM mod_map mod_name (False, False, Just (mod, 0, 0, 0, from, []))
- new_ifaces = ifaces { iImpModInfo = new_mod_map }
- in
- setIfacesRn new_ifaces `thenRn_`
- returnRn (new_ifaces, Just err) ;
-
- -- Found and parsed!
- Right iface ->
-
- -- LOAD IT INTO Ifaces
-
- -- 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).
- -- If we do loadExport first the wrong info gets into the cache (unless we
- -- explicitly tag each export which seems a bit of a bore)
-
- getModuleRn `thenRn` \ this_mod ->
- let
- mod = pi_mod iface
- in
- -- Sanity check. If we're system-importing a module we know nothing at all
- -- about, it should be from a different package to this one
- WARN( not (maybeToBool mod_info) &&
- case from of { ImportBySystem -> True; other -> False } &&
- isLocalModule mod,
- ppr mod )
- foldlRn (loadDecl mod) (iDecls ifaces) (pi_decls iface) `thenRn` \ new_decls ->
- foldlRn (loadInstDecl mod) (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts ->
- loadRules mod (iRules ifaces) (pi_rules iface) `thenRn` \ new_rules ->
- loadFixDecls mod_name (iFixes ifaces) (pi_fixity iface) `thenRn` \ new_fixities ->
- foldlRn (loadDeprec mod) (iDeprecs ifaces) (pi_deprecs iface) `thenRn` \ new_deprecs ->
- mapRn (loadExport this_mod) (pi_exports iface) `thenRn` \ avails_s ->
- let
- -- 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
-
- -- Now add info about this module
- mod_map2 = addToFM mod_map1 mod_name mod_details
- cts = (pi_mod iface, pi_vers iface,
- fst (pi_fixity iface), fst (pi_rules iface),
- from, concat avails_s)
- mod_details = (pi_orphan iface, hi_boot_file, Just cts)
-
- new_ifaces = ifaces { iImpModInfo = mod_map2,
- iDecls = new_decls,
- iFixes = new_fixities,
- iInsts = new_insts,
- iRules = new_rules,
- iDeprecs = new_deprecs }
- 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
- | isLocalModule mod = [ (imp_mod, (has_orphans, is_boot, Nothing))
- | (imp_mod, has_orphans, is_boot, _) <- new_deps
- ]
- | otherwise = [ (imp_mod, (True, False, Nothing))
- | (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, cts) new
- | maybeToBool cts || 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
-
-
------------------------------------------------------
--- Loading the export list
------------------------------------------------------
-
-loadExport :: Module -> ExportItem -> RnM d [AvailInfo]
-loadExport this_mod (mod, entities)
- | mod == moduleName this_mod = returnRn []
- -- 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!
-
- | otherwise
- = mapRn (load_entity mod) entities
- where
- new_name mod occ = newGlobalName mod occ
-
- load_entity mod (Avail occ)
- = new_name mod occ `thenRn` \ name ->
- returnRn (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)
-
-
------------------------------------------------------
--- Loading type/class/value decls
------------------------------------------------------
-
-loadDecl :: Module
- -> DeclsMap
- -> (Version, RdrNameHsDecl)
- -> RnM d DeclsMap
-
-loadDecl mod decls_map (version, decl)
- = getDeclBinders new_name decl `thenRn` \ maybe_avail ->
- case maybe_avail of {
- Nothing -> returnRn decls_map; -- No bindings
- Just avail ->
-
- getDeclSysBinders new_name decl `thenRn` \ sys_bndrs ->
- let
- full_avail = addSysAvails avail sys_bndrs
- -- 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!
-
- main_name = availName avail
- new_decls_map = foldl add_decl decls_map
- [ (name, (version, full_avail, name==main_name, (mod, decl')))
- | name <- availNames full_avail]
- add_decl decls_map (name, stuff)
- = WARN( name `elemNameEnv` decls_map, ppr name )
- extendNameEnv decls_map name stuff
- in
- returnRn new_decls_map
- }
- 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 (rdrNameOcc rdr_name)
-
- {-
- If a signature decl is being loaded, and optIgnoreIfacePragmas is on,
- we toss away unfolding information.
-
- Also, if the signature is loaded from a module we're importing from source,
- we do the same. This is to avoid situations when compiling a pair of mutually
- recursive modules, peering at unfolding info in the interface file of the other,
- e.g., you compile A, it looks at B's interface file and may as a result change
- its interface file. Hence, B is recompiled, maybe changing its interface file,
- which will the unfolding info used in A to become invalid. Simple way out is to
- just ignore unfolding info.
-
- [Jan 99: I junked the second test above. If we're importing from an hi-boot
- file there isn't going to *be* any pragma info. Maybe the above comment
- dates from a time where we picked up a .hi file first if it existed?]
- -}
- decl' = case decl of
- SigD (IfaceSig name tp ls loc) | opt_IgnoreIfacePragmas
- -> SigD (IfaceSig name tp [] loc)
- other -> decl
-
------------------------------------------------------
--- Loading fixity decls
------------------------------------------------------
-
-loadFixDecls mod_name fixity_env (version, decls)
- | null decls = returnRn fixity_env
-
- | otherwise
- = mapRn (loadFixDecl mod_name) decls `thenRn` \ to_add ->
- returnRn (extendNameEnvList fixity_env to_add)
-
-loadFixDecl mod_name sig@(FixitySig rdr_name fixity loc)
- = newGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name ->
- returnRn (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
- -- instance declaration. If all these "gates" are slurped in then
- -- we should slurp the instance decl too.
- --
- -- We *don't* want to count names in the context part as gates, though.
- -- For example:
- -- instance Foo a => Baz (T a) where ...
- --
- -- Here the gates are Baz and T, but *not* Foo.
- let
- munged_inst_ty = removeContext inst_ty
- free_names = extractHsTyRdrNames munged_inst_ty
- in
- setModuleRn mod $
- mapRn lookupOrigName free_names `thenRn` \ gate_names ->
- returnRn ((mkNameSet gate_names, (mod, InstD 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
- -> (Version, [RdrNameRuleDecl])
- -> RnM d IfaceRules
-loadRules mod rule_bag (version, rules)
- | null rules || opt_IgnoreIfacePragmas
- = returnRn rule_bag
- | otherwise
- = setModuleRn mod $
- mapRn (loadRule mod) rules `thenRn` \ new_rules ->
- returnRn (rule_bag `unionBags` listToBag new_rules)
-
-loadRule :: Module -> RdrNameRuleDecl -> RnM d GatedDecl
--- "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))
-
-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)))
-\end{code}
-
-
-%********************************************************
-%* *
-\subsection{Checking usage information}
-%* *
-%********************************************************
-
-\begin{code}
-upToDate = True
-outOfDate = False
-
-checkModUsage :: [ImportVersion OccName] -> RnMG Bool
--- Given the usage information extracted from the old
--- M.hi file for the module being compiled, figure out
--- whether M needs to be recompiled.
-
-checkModUsage [] = returnRn upToDate -- Yes! Everything is up to date!
-
-checkModUsage ((mod_name, _, _, NothingAtAll) : rest)
- -- If CurrentModule.hi contains
- -- import Foo :: ;
- -- then that simply records that Foo lies below CurrentModule in the
- -- hierarchy, but CurrentModule doesn't depend in any way on Foo.
- -- In this case we don't even want to open Foo's interface.
- = traceRn (ptext SLIT("Nothing used from:") <+> ppr mod_name) `thenRn_`
- checkModUsage rest -- This one's ok, so check the rest
-
-checkModUsage ((mod_name, _, _, whats_imported) : rest)
- = tryLoadInterface doc_str mod_name ImportBySystem `thenRn` \ (ifaces, maybe_err) ->
- case maybe_err of {
- Just err -> out_of_date (sep [ptext SLIT("Can't find version number for module"),
- pprModuleName mod_name]) ;
- -- Couldn't find or parse a module mentioned in the
- -- old interface file. Don't complain -- it might just be that
- -- the current module doesn't need that import and it's been deleted
-
- Nothing ->
- let
- (_, new_mod_vers, new_fix_vers, new_rule_vers, _, _)
- = case lookupFM (iImpModInfo ifaces) mod_name of
- Just (_, _, Just stuff) -> stuff
-
- old_mod_vers = case whats_imported of
- Everything v -> v
- Specifically v _ _ _ -> v
- -- NothingAtAll case dealt with by previous eqn for checkModUsage
- in
- -- If the module version hasn't changed, just move on
- if new_mod_vers == old_mod_vers then
- traceRn (sep [ptext SLIT("Module version unchanged:"), pprModuleName mod_name])
- `thenRn_` checkModUsage rest
- else
- traceRn (sep [ptext SLIT("Module version has changed:"), pprModuleName mod_name])
- `thenRn_`
- -- Module version changed, so check entities inside
-
- -- If the usage info wants to say "I imported everything from this module"
- -- it does so by making whats_imported equal to Everything
- -- In that case, we must recompile
- case whats_imported of { -- NothingAtAll dealt with earlier
-
- Everything _
- -> out_of_date (ptext SLIT("...and I needed the whole module")) ;
-
- Specifically _ old_fix_vers old_rule_vers old_local_vers ->
-
- if old_fix_vers /= new_fix_vers then
- out_of_date (ptext SLIT("Fixities changed"))
- else if old_rule_vers /= new_rule_vers then
- out_of_date (ptext SLIT("Rules changed"))
- else
- -- Non-empty usage list, so check item by item
- checkEntityUsage mod_name (iDecls ifaces) old_local_vers `thenRn` \ up_to_date ->
- if up_to_date then
- traceRn (ptext SLIT("...but the bits I use haven't.")) `thenRn_`
- checkModUsage rest -- This one's ok, so check the rest
- else
- returnRn outOfDate -- This one failed, so just bail out now
- }}
- where
- doc_str = sep [ptext SLIT("need version info for"), pprModuleName mod_name]
-
-
-checkEntityUsage mod decls []
- = returnRn upToDate -- Yes! All up to date!
-
-checkEntityUsage mod decls ((occ_name,old_vers) : rest)
- = newGlobalName mod occ_name `thenRn` \ name ->
- case lookupNameEnv decls name of
-
- Nothing -> -- We used it before, but it ain't there now
- out_of_date (sep [ptext SLIT("No longer exported:"), ppr name])
-
- Just (new_vers,_,_,_) -- It's there, but is it up to date?
- | new_vers == old_vers
- -- Up to date, so check the rest
- -> checkEntityUsage mod decls rest
-
- | otherwise
- -- Out of date, so bale out
- -> out_of_date (sep [ptext SLIT("Out of date:"), ppr name])
-
-out_of_date msg = traceRn msg `thenRn_` returnRn outOfDate
-\end{code}
-
-
-%*********************************************************
-%* *
-\subsection{Getting in a declaration}
-%* *
-%*********************************************************
-
-\begin{code}
-importDecl :: Name -> RnMG ImportDeclResult
-
-data ImportDeclResult
- = AlreadySlurped
- | WiredIn
- | Deferred
- | HereItIs (Module, RdrNameHsDecl)
-
-importDecl name
- = getSlurped `thenRn` \ already_slurped ->
- if name `elemNameSet` already_slurped then
- returnRn AlreadySlurped -- Already dealt with
-
- else if isLocallyDefined name then -- Don't bring in decls from
- -- the renamed module's own interface file
- addWarnRn (importDeclWarn name) `thenRn_`
- returnRn AlreadySlurped
-
- else if isWiredInName name then
- -- When we find a wired-in name we must load its
- -- home module so that we find any instance decls therein
- loadHomeInterface doc name `thenRn_`
- returnRn WiredIn
-
- else getNonWiredInDecl name
- where
- doc = ptext SLIT("need home module for wired in thing") <+> ppr name
-
-
-{- I don't think this is necessary any more; SLPJ May 00
- load_home name
- | name `elemNameSet` source_binders = returnRn ()
- -- When compiling the prelude, a wired-in thing may
- -- be defined in this module, in which case we don't
- -- want to load its home module!
- -- Using 'isLocallyDefined' doesn't work because some of
- -- the free variables returned are simply 'listTyCon_Name',
- -- with a system provenance. We could look them up every time
- -- but that seems a waste.
- | otherwise = loadHomeInterface doc name `thenRn_`
- returnRn ()
--}
-
-getNonWiredInDecl :: Name -> RnMG ImportDeclResult
-getNonWiredInDecl needed_name
- = traceRn doc_str `thenRn_`
- loadHomeInterface doc_str needed_name `thenRn` \ ifaces ->
- case lookupNameEnv (iDecls ifaces) needed_name of
-
- Just (version, avail, is_tycon_name, decl@(_, TyClD (TyData DataType _ _ _ _ ncons _ _ _ _ _)))
- -- This case deals with deferred import of algebraic data types
-
- | not opt_NoPruneTyDecls
-
- && (opt_IgnoreIfacePragmas || ncons > 1)
- -- We only defer if imported interface pragmas are ingored
- -- or if it's not a product type.
- -- Sole reason: The wrapper for a strict function may need to look
- -- inside its arg, and hence need to see its arg type's constructors.
-
- && not (getUnique tycon_name `elem` cCallishTyKeys)
- -- Never defer ccall types; we have to unbox them,
- -- and importing them does no harm
-
- -> -- OK, so we're importing a deferrable data type
- if needed_name == tycon_name then
- -- The needed_name is the TyCon of a data type decl
- -- Record that it's slurped, put it in the deferred set
- -- and don't return a declaration at all
- setIfacesRn (recordSlurp (ifaces {iDeferred = iDeferred ifaces
- `addOneToNameSet` tycon_name})
- version (AvailTC needed_name [needed_name])) `thenRn_`
- returnRn Deferred
- else
- -- The needed name is a constructor of a data type decl,
- -- getting a constructor, so remove the TyCon from the deferred set
- -- (if it's there) and return the full declaration
- setIfacesRn (recordSlurp (ifaces {iDeferred = iDeferred ifaces
- `delFromNameSet` tycon_name})
- version avail) `thenRn_`
- returnRn (HereItIs decl)
- where
- tycon_name = availName avail
-
- Just (version,avail,_,decl)
- -> setIfacesRn (recordSlurp ifaces version avail) `thenRn_`
- returnRn (HereItIs decl)
-
- Nothing
- -> addErrRn (getDeclErr needed_name) `thenRn_`
- returnRn AlreadySlurped
- where
- doc_str = ptext SLIT("need decl for") <+> ppr needed_name
-
-getDeferredDecls :: RnMG [(Module, RdrNameHsDecl)]
-getDeferredDecls
- = getIfacesRn `thenRn` \ ifaces ->
- let
- decls_map = iDecls ifaces
- deferred_names = nameSetToList (iDeferred ifaces)
- get_abstract_decl n = case lookupNameEnv decls_map n of
- Just (_, _, _, decl) -> decl
- in
- traceRn (sep [text "getDeferredDecls", nest 4 (fsep (map ppr deferred_names))]) `thenRn_`
- returnRn (map get_abstract_decl deferred_names)