Commit 613c5f6d authored by Simon Marlow's avatar Simon Marlow

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

parent 6cd3d0dc
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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'.
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment