Rename -XPArr to -XParallelArrays

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

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index d64e98e..15b142b 100644 (file)
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -5,7 +5,7 @@
 
 \begin{code}
 module ErrUtils (
-       Message, mkLocMessage, printError,
+       Message, mkLocMessage, printError, pprMessageBag,
        Severity(..),
 
        ErrMsg, WarnMsg,
@@ -13,12 +13,12 @@ module ErrUtils (
         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
@@ -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
@@ -49,8 +48,12 @@ 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
@@ -122,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 = 
@@ -202,19 +178,6 @@ dumpIfSet flag hdr doc
   | 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 
@@ -320,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