Major patch to fix reporting of unused imports

[ghc-hetmet.git] / compiler / main / GHC.hs

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 72806cb..8cf1666 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,
@@ -264,10 +265,10 @@ import Var
 import TysPrim         ( alphaTyVars )
 import TyCon
 import Class
-import FunDeps
+-- import FunDeps
 import DataCon
 import Name             hiding ( varName )
-import OccName         ( parenSymOcc )
+-- import OccName              ( parenSymOcc )
 import InstEnv         ( Instance, instanceDFunId, pprInstance, pprInstanceHdr,
                           emptyInstEnv )
 import FamInstEnv       ( emptyFamInstEnv )
@@ -275,7 +276,7 @@ import SrcLoc
 --import CoreSyn
 import TidyPgm
 import DriverPipeline
-import DriverPhases    ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase )
+import DriverPhases    ( Phase(..), isHaskellSrcFilename, startPhase )
 import HeaderInfo
 import Finder
 import HscMain
@@ -783,7 +784,7 @@ load2 how_much mod_graph = do
                                (flattenSCCs mg2_with_srcimps)
                                stable_mods
 
-       liftIO $ evaluate pruned_hpt
+       _ <- liftIO $ evaluate pruned_hpt
 
         -- before we unload anything, make sure we don't leave an old
         -- interactive context around pointing to dead bindings.  Also,
@@ -887,7 +888,7 @@ load2 how_much mod_graph = do
              let 
                main_mod = mainModIs dflags
                a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
-               do_linking = a_root_is_Main || no_hs_main
+               do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib
 
              when (ghcLink dflags == LinkBinary 
                     && isJust ofile && not do_linking) $
@@ -1207,7 +1208,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do
   (iface, changed, _details, cgguts)
       <- hscNormalIface guts Nothing
   hscWriteIface iface changed modSummary
-  hscGenHardCode cgguts modSummary
+  _ <- hscGenHardCode cgguts modSummary
   return ()
 
 -- Makes a "vanilla" ModGuts.
@@ -1241,7 +1242,7 @@ compileCore simplify fn = do
    -- First, set the target to the desired filename
    target <- guessTarget fn Nothing
    addTarget target
-   load LoadAllTargets
+   _ <- load LoadAllTargets
    -- Then find dependencies
    modGraph <- depanal [] True
    case find ((== fn) . msHsFilePath) modGraph of
@@ -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