\begin{code}
module ErrUtils (
- Message, mkLocMessage, printError,
+ Message, mkLocMessage, printError, pprMessageBag,
Severity(..),
ErrMsg, WarnMsg,
- errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
+ ErrorMessages, WarningMessages,
+ errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
Messages, errorsFound, emptyMessages,
- mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg,
+ mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
- handleFlagWarnings,
+ warnIsErrorMsg, mkLongWarnMsg,
ghcExit,
doIfSet, doIfSet_dyn,
- dumpIfSet, dumpIf_core, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or,
+ dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_or,
mkDumpDoc, dumpSDoc,
-- * Messages during compilation
#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
type Message = SDoc
+pprMessageBag :: Bag Message -> SDoc
+pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
+
data Severity
- = SevInfo
+ = SevOutput
+ | SevInfo
| SevWarning
| SevError
| SevFatal
errMsgExtraInfo :: Message
}
-- The SrcSpan is used for sorting errors into line-number order
- -- 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
-- to qualify names in the message or not.
mkErrMsg :: SrcSpan -> PrintUnqualified -> Message -> ErrMsg
mkErrMsg locn print_unqual msg
- = ErrMsg [locn] print_unqual msg empty
+ = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual
+ , errMsgShortDoc = msg, errMsgExtraInfo = empty }
-- Variant that doesn't care about qualified/unqualified names
mkPlainErrMsg :: SrcSpan -> Message -> ErrMsg
mkPlainErrMsg locn msg
- = ErrMsg [locn] alwaysQualify msg empty
+ = ErrMsg { errMsgSpans = [locn], errMsgContext = alwaysQualify
+ , errMsgShortDoc = msg, errMsgExtraInfo = empty }
-- A long (multi-line) error message, with context to tell us whether
-- to qualify names in the message or not.
mkLongErrMsg :: SrcSpan -> PrintUnqualified -> Message -> Message -> ErrMsg
mkLongErrMsg locn print_unqual msg extra
- = ErrMsg [locn] print_unqual msg extra
+ = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual
+ , errMsgShortDoc = msg, errMsgExtraInfo = extra }
mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg
mkWarnMsg = mkErrMsg
+mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> Message -> ErrMsg
+mkLongWarnMsg = mkLongErrMsg
+
+-- 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)
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
| not flag = return ()
| otherwise = printDump (mkDumpDoc hdr doc)
-dumpIf_core :: Bool -> DynFlags -> DynFlag -> String -> SDoc -> IO ()
-dumpIf_core cond dflags dflag hdr doc
- | cond
- || verbosity dflags >= 4
- || dopt Opt_D_verbose_core2core dflags
- = dumpSDoc dflags dflag hdr doc
-
- | otherwise = return ()
-
-dumpIfSet_core :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
-dumpIfSet_core dflags flag hdr doc
- = dumpIf_core (dopt flag dflags) dflags flag hdr doc
-
dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn dflags flag hdr doc
| dopt flag dflags || verbosity dflags >= 4
mkDumpDoc :: String -> SDoc -> SDoc
mkDumpDoc hdr doc
- = vcat [text "",
+ = vcat [blankLine,
line <+> text hdr <+> line,
doc,
- text ""]
+ blankLine]
where
line = text (replicate 20 '=')
compilationProgressMsg :: DynFlags -> String -> IO ()
compilationProgressMsg dflags msg
- = ifVerbose dflags 1 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text msg))
+ = ifVerbose dflags 1 (log_action dflags SevOutput noSrcSpan defaultUserStyle (text msg))
showPass :: DynFlags -> String -> IO ()
showPass dflags what