diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/ghci/InteractiveUI.hs | 4 | ||||
| -rw-r--r-- | compiler/main/Finder.lhs | 1 | ||||
| -rw-r--r-- | compiler/main/GHC.hs | 70 |
3 files changed, 56 insertions, 19 deletions
diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 327cf149b9..e0c49ceed6 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -335,7 +335,7 @@ interactiveUI srcs maybe_exprs = withTerminalReset $ do #endif -- initial context is just the Prelude - prel_mod <- GHC.findModule (GHC.mkModuleName "Prelude") Nothing + prel_mod <- GHC.lookupModule (GHC.mkModuleName "Prelude") Nothing GHC.setContext [] [prel_mod] default_editor <- liftIO $ findEditor @@ -2356,7 +2356,7 @@ mkTickArray ticks lookupModule :: String -> GHCi Module lookupModule modName - = GHC.findModule (GHC.mkModuleName modName) Nothing + = GHC.lookupModule (GHC.mkModuleName modName) Nothing -- don't reset the counter back to zero? discardActiveBreakPoints :: GHCi () diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs index 1d43591acd..7587bb30eb 100644 --- a/compiler/main/Finder.lhs +++ b/compiler/main/Finder.lhs @@ -10,6 +10,7 @@ module Finder ( findImportedModule, findExactModule, findHomeModule, + findExposedPackageModule, mkHomeModLocation, mkHomeModLocation2, mkHiOnlyModLocation, diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 72806cbf94..c5571cbd9f 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -89,6 +89,7 @@ module GHC ( -- * Interactive evaluation getBindings, getPrintUnqual, findModule, + lookupModule, #ifdef GHCI setContext, getContext, getNamesInScope, @@ -2648,23 +2649,58 @@ showRichTokenStream ts = go startLoc ts "" -- filesystem and package database to find the corresponding 'Module', -- using the algorithm that is used for an @import@ declaration. findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module -findModule mod_name maybe_pkg = withSession $ \hsc_env -> liftIO $ -- XXX - let - dflags = hsc_dflags hsc_env - hpt = hsc_HPT hsc_env - this_pkg = thisPackage dflags - in - case lookupUFM hpt mod_name of - Just mod_info -> return (mi_module (hm_iface mod_info)) - _not_a_home_module -> do - res <- findImportedModule hsc_env mod_name maybe_pkg - case res of - Found _ m | modulePackageId m /= this_pkg -> return m - | otherwise -> ghcError (CmdLineError (showSDoc $ - text "module" <+> quotes (ppr (moduleName m)) <+> - text "is not loaded")) - err -> let msg = cannotFindModule dflags mod_name err in - ghcError (CmdLineError (showSDoc msg)) +findModule mod_name maybe_pkg = withSession $ \hsc_env -> do + let + dflags = hsc_dflags hsc_env + this_pkg = thisPackage dflags + -- + case maybe_pkg of + Just pkg | fsToPackageId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do + res <- findImportedModule hsc_env mod_name maybe_pkg + case res of + Found _ m -> return m + err -> noModError dflags noSrcSpan mod_name err + _otherwise -> do + home <- lookupLoadedHomeModule mod_name + case home of + Just m -> return m + Nothing -> liftIO $ do + res <- findImportedModule hsc_env mod_name maybe_pkg + case res of + Found loc m | modulePackageId m /= this_pkg -> return m + | otherwise -> modNotLoadedError m loc + err -> noModError dflags noSrcSpan mod_name err + +modNotLoadedError :: Module -> ModLocation -> IO a +modNotLoadedError m loc = ghcError $ CmdLineError $ showSDoc $ + text "module is not loaded:" <+> + quotes (ppr (moduleName m)) <+> + parens (text (expectJust "modNotLoadedError" (ml_hs_file loc))) + +-- | Like 'findModule', but differs slightly when the module refers to +-- a source file, and the file has not been loaded via 'load'. In +-- this case, 'findModule' will throw an error (module not loaded), +-- but 'lookupModule' will check to see whether the module can also be +-- found in a package, and if so, that package 'Module' will be +-- returned. If not, the usual module-not-found error will be thrown. +-- +lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module +lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg) +lookupModule mod_name Nothing = withSession $ \hsc_env -> do + home <- lookupLoadedHomeModule mod_name + case home of + Just m -> return m + Nothing -> liftIO $ do + res <- findExposedPackageModule hsc_env mod_name Nothing + case res of + Found _ m -> return m + err -> noModError (hsc_dflags hsc_env) noSrcSpan mod_name err + +lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module) +lookupLoadedHomeModule mod_name = withSession $ \hsc_env -> + case lookupUFM (hsc_HPT hsc_env) mod_name of + Just mod_info -> return (Just (mi_module (hm_iface mod_info))) + _not_a_home_module -> return Nothing #ifdef GHCI getHistorySpan :: GhcMonad m => History -> m SrcSpan |