FIX #2682: banish silly cases of the "module Foo is not loaded" error

In GHCi if you say 'import Foo' meaning to load a package module Foo,
and Foo.hs is found on the search path, then GHCi replies "module Foo
is not loaded", because it knows Foo refers to the source file rather
than the package module, and you haven't loaded that module with
:load.

This is consistent with the usual module-finding semantics.  However,
it isn't particularly useful.  And it leads to silly problems like not
being able to start GHCi when you happen to be sitting in
libraries/base, because GHCi thinks the Prelude hasn't been loaded.

So now I've made a slight change to the way that 'import M' works: if
M is loaded, then it refers to the loaded module, otherwise it looks
for a package module M.  This does what the reporter of #2682 wanted,
and since it turns an error condition into meaningful behaviour it
can't break anything.

The only undesirable consequence is that 'import M' might refer to a
different M than ':load M'.  Hopefully that won't lead to confusion.

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index 327cf14..e0c49ce 100644 (file)
--- 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 1d43591..7587bb3 100644 (file)
--- 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 72806cb..c5571cb 100644 (file)
--- 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