fix #2636: throw missing module errors as SourceErrors, not ErrMsg

4 files changed, 19 insertions, 40 deletions

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index d98fddb1ef..d37dba9ecf 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -8,7 +8,7 @@ module ErrUtils (
 	Message, mkLocMessage, printError,
 	Severity(..),
 
-	ErrMsg, WarnMsg, throwErrMsg, handleErrMsg,
+	ErrMsg, WarnMsg,
     ErrorMessages, WarningMessages,
 	errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
 	Messages, errorsFound, emptyMessages,
@@ -42,10 +42,8 @@ import StaticFlags	( opt_ErrorSpans )
 
 import Control.Monad
 import System.Exit	( ExitCode(..), exitWith )
-import Data.Dynamic
 import Data.List
 import System.IO
-import Exception
 
 -- -----------------------------------------------------------------------------
 -- Basic error messages: just render a message with a source location.
@@ -83,24 +81,9 @@ data ErrMsg = ErrMsg {
 	-- NB  Pretty.Doc not SDoc: we deal with the printing style (in ptic 
 	-- whether to qualify an External Name) at the error occurrence
 
-instance Exception ErrMsg
-
 instance Show ErrMsg where
     show em = showSDoc (errMsgShortDoc em)
 
-throwErrMsg :: ErrMsg -> a
-throwErrMsg = throw
-
-handleErrMsg :: ExceptionMonad m => (ErrMsg -> m a) -> m a -> m a
-handleErrMsg = ghandle
-
--- So we can throw these things as exceptions
-errMsgTc :: TyCon
-errMsgTc = mkTyCon "ErrMsg"
-{-# NOINLINE errMsgTc #-}
-instance Typeable ErrMsg where
-  typeOf _ = mkTyConApp errMsgTc []
-
 type WarnMsg = ErrMsg
 
 -- A short (one-line) error message, with context to tell us whether
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 38208a0c69..82fbf5b362 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -328,13 +328,6 @@ defaultErrorHandler dflags inner =
            exitWith (ExitFailure 1)
          ) $
 
-  -- program errors: messages with locations attached.  Sometimes it is
-  -- convenient to just throw these as exceptions.
-  handleErrMsg
-            (\em -> liftIO $ do
-                      printBagOfErrors dflags (unitBag em)
-                      exitWith (ExitFailure 1)) $
-
   -- error messages propagated as exceptions
   handleGhcException
             (\ge -> liftIO $ do
@@ -1864,7 +1857,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
 		if exists 
 		    then summariseFile hsc_env old_summaries file mb_phase 
                                        obj_allowed maybe_buf
-		    else throwErrMsg $ mkPlainErrMsg noSrcSpan $
+		    else throwOneError $ mkPlainErrMsg noSrcSpan $
 			   text "can't find file:" <+> text file
 	getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)
  	   = do maybe_summary <- summariseModule hsc_env old_summary_map False 
@@ -2128,7 +2121,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
         (srcimps, the_imps, L mod_loc mod_name) <- liftIO $ getImports dflags' buf hspp_fn src_fn
 
 	when (mod_name /= wanted_mod) $
-		throwErrMsg $ mkPlainErrMsg mod_loc $ 
+		throwOneError $ mkPlainErrMsg mod_loc $ 
 			      text "File name does not match module name:" 
 			      $$ text "Saw:" <+> quotes (ppr mod_name)
                               $$ text "Expected:" <+> quotes (ppr wanted_mod)
@@ -2204,21 +2197,21 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
 noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
 -- ToDo: we don't have a proper line number for this error
 noModError dflags loc wanted_mod err
-  = throwErrMsg $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
+  = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
 				
-noHsFileErr :: SrcSpan -> String -> a
+noHsFileErr :: GhcMonad m => SrcSpan -> String -> m a
 noHsFileErr loc path
-  = throwErrMsg $ mkPlainErrMsg loc $ text "Can't find" <+> text path
+  = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path
  
-packageModErr :: ModuleName -> a
+packageModErr :: GhcMonad m => ModuleName -> m a
 packageModErr mod
-  = throwErrMsg $ mkPlainErrMsg noSrcSpan $
+  = throwOneError $ mkPlainErrMsg noSrcSpan $
 	text "module" <+> quotes (ppr mod) <+> text "is a package module"
 
 multiRootsErr :: [ModSummary] -> IO ()
 multiRootsErr [] = panic "multiRootsErr"
 multiRootsErr summs@(summ1:_)
-  = throwErrMsg $ mkPlainErrMsg noSrcSpan $
+  = throwOneError $ mkPlainErrMsg noSrcSpan $
 	text "module" <+> quotes (ppr mod) <+> 
 	text "is defined in multiple files:" <+>
 	sep (map text files)
diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index 22f645efd5..daa66c7736 100644
--- a/compiler/main/HeaderInfo.hs
+++ b/compiler/main/HeaderInfo.hs
@@ -22,6 +22,7 @@ module HeaderInfo ( getImports
 
 #include "HsVersions.h"
 
+import HscTypes
 import Parser		( parseHeader )
 import Lexer
 import FastString
@@ -70,8 +71,8 @@ getImports dflags buf filename source_filename = do
 	      in
 	      return (source_imps, ordinary_imps, mod)
   
-parseError :: SrcSpan -> Message -> a
-parseError span err = throwErrMsg $ mkPlainErrMsg span err
+parseError :: SrcSpan -> Message -> IO a
+parseError span err = throwOneError $ mkPlainErrMsg span err
 
 -- we aren't interested in package imports here, filter them out
 isHomeImp :: ImportDecl name -> Bool
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 94d0f9e140..cb41de51f1 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -13,7 +13,7 @@ module HscTypes (
         ioMsgMaybe, ioMsg,
         logWarnings, clearWarnings, hasWarnings,
         SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr,
-        handleSourceError,
+        throwOneError, handleSourceError,
         reflectGhc, reifyGhc,
 
 	-- * Sessions and compilation state
@@ -143,11 +143,10 @@ import FastString
 import StringBuffer	( StringBuffer )
 import Fingerprint
 import MonadUtils
-import Bag              ( emptyBag, unionBags, isEmptyBag )
 import Data.Dynamic     ( Typeable )
 import qualified Data.Dynamic as Dyn
-import Bag              ( bagToList )
-import ErrUtils         ( ErrorMessages, WarningMessages, Messages )
+import Bag
+import ErrUtils
 
 import System.FilePath
 import System.Time	( ClockTime )
@@ -177,6 +176,9 @@ mkSrcErr :: ErrorMessages -> SourceError
 srcErrorMessages :: SourceError -> ErrorMessages
 mkApiErr :: SDoc -> GhcApiError
 
+throwOneError :: MonadIO m => ErrMsg -> m ab
+throwOneError err = liftIO $ throwIO $ mkSrcErr $ unitBag err
+
 -- | A source error is an error that is caused by one or more errors in the
 -- source code.  A 'SourceError' is thrown by many functions in the
 -- compilation pipeline.  Inside GHC these errors are merely printed via
@@ -368,7 +370,7 @@ ioMsgMaybe ioA = do
   ((warns,errs), mb_r) <- liftIO ioA
   logWarnings warns
   case mb_r of
-    Nothing -> throw (mkSrcErr errs)
+    Nothing -> liftIO $ throwIO (mkSrcErr errs)
     Just r  -> ASSERT( isEmptyBag errs ) return r
 
 -- | Lift a non-failing IO action into a 'GhcMonad'.