Message, mkLocMessage, printError,
Severity(..),
- ErrMsg, WarnMsg, throwErrMsg, handleErrMsg,
+ ErrMsg, WarnMsg,
+ ErrorMessages, WarningMessages,
errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
Messages, errorsFound, emptyMessages,
- mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg,
+ mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
- handleFlagWarnings,
+ warnIsErrorMsg,
ghcExit,
doIfSet, doIfSet_dyn,
#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
-import Exception
-- -----------------------------------------------------------------------------
-- Basic error messages: just render a message with a source location.
-- NB Pretty.Doc not SDoc: we deal with the printing style (in ptic
-- whether to qualify an External Name) at the error occurrence
-#if __GLASGOW_HASKELL__ >= 609
-instance Exception ErrMsg
-#endif
-
instance Show ErrMsg where
show em = showSDoc (errMsgShortDoc em)
-throwErrMsg :: ErrMsg -> a
-#if __GLASGOW_HASKELL__ < 609
-throwErrMsg = throwDyn
-#else
-throwErrMsg = throw
-#endif
-
-handleErrMsg :: (ErrMsg -> IO a) -> IO a -> IO a
-#if __GLASGOW_HASKELL__ < 609
-handleErrMsg = flip catchDyn
-#else
-handleErrMsg = handle
-#endif
-
--- 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
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
-- -Werror, which says that warnings should be fatal
EQ -> True
GT -> False
-handleFlagWarnings :: DynFlags -> [String] -> IO ()
-handleFlagWarnings dflags warns
- = when (dopt Opt_WarnDeprecatedFlags dflags)
- (handleFlagWarnings' dflags warns)
-
-handleFlagWarnings' :: DynFlags -> [String] -> IO ()
-handleFlagWarnings' _ [] = return ()
-handleFlagWarnings' dflags warns
- = do -- It would be nicer if warns :: [Message], but that has circular
- -- import problems.
- let warns' = map text warns
- mapM_ (log_action dflags SevWarning noSrcSpan defaultUserStyle) warns'
- when (dopt Opt_WarnIsError dflags) $
- do errorMsg dflags $ text "\nFailing due to -Werror.\n"
- exitWith (ExitFailure 1)
-
ghcExit :: DynFlags -> Int -> IO ()
ghcExit dflags val
| val == 0 = exitWith ExitSuccess