\begin{code}
module ErrUtils (
- Message, mkLocMessage, printError,
+ Message, mkLocMessage, printError, pprMessageBag,
Severity(..),
ErrMsg, WarnMsg,
ErrorMessages, WarningMessages,
+ errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
Messages, errorsFound, emptyMessages,
mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
- printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
+ printBagOfErrors, printBagOfWarnings,
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
- putMsg,
+ putMsg, putMsgWith,
errorMsg,
fatalErrorMsg,
compilationProgressMsg,
import DynFlags ( DynFlags(..), DynFlag(..), dopt )
import StaticFlags ( opt_ErrorSpans )
-import Control.Monad
import System.Exit ( ExitCode(..), exitWith )
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
-- would look strange. Better to say explicitly "<no location info>".
printError :: SrcSpan -> Message -> IO ()
-printError span msg = printErrs (mkLocMessage span msg $ defaultErrStyle)
+printError span msg =
+ printErrs (mkLocMessage span msg) defaultErrStyle
-- -----------------------------------------------------------------------------
emptyMessages = (emptyBag, emptyBag)
warnIsErrorMsg :: ErrMsg
-warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.\n")
+warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.")
errorsFound :: DynFlags -> Messages -> Bool
--- The dyn-flags are used to see if the user has specified
--- -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 = 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
+errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
-printBagOfErrors dflags bag_of_errors
- = sequence_ [ let style = mkErrStyle unqual
- in log_action dflags SevError s style (d $$ e)
- | ErrMsg { errMsgSpans = s:_,
- errMsgShortDoc = d,
- errMsgExtraInfo = e,
- errMsgContext = unqual } <- sorted_errs ]
- where
- bag_ls = bagToList bag_of_errors
- sorted_errs = sortLe occ'ed_before bag_ls
+printBagOfErrors dflags bag_of_errors =
+ printMsgBag dflags bag_of_errors SevError
- occ'ed_before err1 err2 =
- case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of
- LT -> True
- EQ -> True
- GT -> False
+printBagOfWarnings :: DynFlags -> Bag WarnMsg -> IO ()
+printBagOfWarnings dflags bag_of_warns =
+ printMsgBag dflags bag_of_warns SevWarning
-printBagOfWarnings :: DynFlags -> Bag ErrMsg -> IO ()
-printBagOfWarnings dflags bag_of_warns
+printMsgBag :: DynFlags -> Bag ErrMsg -> Severity -> IO ()
+printMsgBag dflags bag sev
= sequence_ [ let style = mkErrStyle unqual
- in log_action dflags SevWarning s style (d $$ e)
+ in log_action dflags sev s style (d $$ e)
| ErrMsg { errMsgSpans = s:_,
errMsgShortDoc = d,
errMsgExtraInfo = e,
errMsgContext = unqual } <- sorted_errs ]
where
- bag_ls = bagToList bag_of_warns
+ bag_ls = bagToList bag
sorted_errs = sortLe occ'ed_before bag_ls
occ'ed_before err1 err2 =
| 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
putMsg :: DynFlags -> Message -> IO ()
putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg
+putMsgWith :: DynFlags -> PrintUnqualified -> Message -> IO ()
+putMsgWith dflags print_unqual msg
+ = log_action dflags SevInfo noSrcSpan sty msg
+ where
+ sty = mkUserStyle print_unqual AllTheWay
+
errorMsg :: DynFlags -> Message -> IO ()
errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg
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