Rename -XPArr to -XParallelArrays

[ghc-hetmet.git] / compiler / main / ErrUtils.lhs

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index f1328e0..15b142b 100644 (file)
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -13,7 +13,7 @@ module ErrUtils (
         errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
        Messages, errorsFound, emptyMessages,
        mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
-       printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
+       printBagOfErrors, printBagOfWarnings,
        warnIsErrorMsg, mkLongWarnMsg,
 
        ghcExit,
@@ -39,7 +39,6 @@ import SrcLoc
 import DynFlags                ( DynFlags(..), DynFlag(..), dopt )
 import StaticFlags     ( opt_ErrorSpans )
 
-import Control.Monad
 import System.Exit     ( ExitCode(..), exitWith )
 import Data.List
 import System.IO
@@ -53,7 +52,8 @@ pprMessageBag :: Bag Message -> SDoc
 pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
 
 data Severity
-  = SevInfo
+  = SevOutput
+  | SevInfo
   | SevWarning
   | SevError
   | SevFatal
@@ -125,56 +125,29 @@ emptyMessages :: Messages
 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 = 
@@ -310,7 +283,7 @@ fatalErrorMsg dflags msg = log_action dflags SevFatal noSrcSpan defaultErrStyle
 
 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