X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FErrUtils.lhs;h=9159a3e35c05f794e11a0ce1f3d9329c43f2f071;hb=1246293616fc45787ecaed13aa31a2555510f7e3;hp=72d0e930bcb347de0c015a0b0cc2988beb892a69;hpb=b4229ab662b6d87b1477bafa85d2db46e5a9a152;p=ghc-hetmet.git diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 72d0e93..9159a3e 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -9,10 +9,12 @@ module ErrUtils ( Severity(..), ErrMsg, WarnMsg, + ErrorMessages, WarningMessages, errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, Messages, errorsFound, emptyMessages, - mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg, + mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg, printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings, + warnIsErrorMsg, ghcExit, doIfSet, doIfSet_dyn, @@ -28,20 +30,17 @@ module ErrUtils ( debugTraceMsg, ) where --- XXX This define is a bit of a hack, and should be done more nicely -#define FAST_STRING_NOT_NEEDED 1 #include "HsVersions.h" import Bag ( Bag, bagToList, isEmptyBag, emptyBag ) -import SrcLoc ( SrcSpan ) import Util ( sortLe ) import Outputable -import SrcLoc ( srcSpanStart, noSrcSpan ) +import SrcLoc import DynFlags ( DynFlags(..), DynFlag(..), dopt ) import StaticFlags ( opt_ErrorSpans ) +import Control.Monad import System.Exit ( ExitCode(..), exitWith ) -import Data.Dynamic import Data.List import System.IO @@ -81,16 +80,8 @@ 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 --- So we can throw these things as exceptions -errMsgTc :: TyCon -errMsgTc = mkTyCon "ErrMsg" -{-# NOINLINE errMsgTc #-} -instance Typeable ErrMsg where -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603 - typeOf _ = mkAppTy errMsgTc [] -#else - typeOf _ = mkTyConApp errMsgTc [] -#endif +instance Show ErrMsg where + show em = showSDoc (errMsgShortDoc em) type WarnMsg = ErrMsg @@ -114,24 +105,37 @@ mkLongErrMsg locn print_unqual msg extra mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg mkWarnMsg = mkErrMsg +-- Variant that doesn't care about qualified/unqualified names +mkPlainWarnMsg :: SrcSpan -> Message -> ErrMsg +mkPlainWarnMsg locn msg = mkWarnMsg locn alwaysQualify msg + type Messages = (Bag WarnMsg, Bag ErrMsg) +type WarningMessages = Bag WarnMsg +type ErrorMessages = Bag ErrMsg + emptyMessages :: Messages emptyMessages = (emptyBag, emptyBag) +warnIsErrorMsg :: ErrMsg +warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.\n") + errorsFound :: DynFlags -> Messages -> Bool -- The dyn-flags are used to see if the user has specified --- -Werorr, which says that warnings should be fatal +-- -Werror, which says that warnings should be fatal errorsFound dflags (warns, errs) | dopt Opt_WarnIsError dflags = not (isEmptyBag errs) || not (isEmptyBag warns) | otherwise = not (isEmptyBag errs) printErrorsAndWarnings :: DynFlags -> Messages -> IO () printErrorsAndWarnings dflags (warns, errs) - | no_errs && no_warns = return () - | no_errs = printBagOfWarnings dflags warns - -- Don't print any warnings if there are errors - | otherwise = printBagOfErrors dflags errs + | no_errs && no_warns = return () + | no_errs = do printBagOfWarnings dflags warns + when (dopt Opt_WarnIsError dflags) $ + errorMsg dflags $ + text "\nFailing due to -Werror.\n" + -- Don't print any warnings if there are errors + | otherwise = printBagOfErrors dflags errs where no_warns = isEmptyBag warns no_errs = isEmptyBag errs @@ -172,8 +176,6 @@ printBagOfWarnings dflags bag_of_warns EQ -> True GT -> False - - ghcExit :: DynFlags -> Int -> IO () ghcExit dflags val | val == 0 = exitWith ExitSuccess