From 613c5f6d88a3dd7df56af1d0f3780b885a0d17cd Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Fri, 10 Oct 2008 13:15:35 +0000 Subject: [PATCH] fix #2636: throw missing module errors as SourceErrors, not ErrMsg --- compiler/main/ErrUtils.lhs | 19 +------------------ compiler/main/GHC.hs | 23 ++++++++--------------- compiler/main/HeaderInfo.hs | 5 +++-- compiler/main/HscTypes.lhs | 12 +++++++----- 4 files changed, 19 insertions(+), 40 deletions(-) diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index d98fddb..d37dba9 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 38208a0..82fbf5b 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 22f645e..daa66c7 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 94d0f9e..cb41de5 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'. -- 1.7.10.4