X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FErrUtils.lhs;h=d0a8a862a46d3b4f1dfdd31d1df6b0d162199f9f;hb=3deca8f44135bd1a146902f498189af00dd4d7b4;hp=f1328e0da7b32d8e46d55067a0df92c58b896bfa;hpb=d4f4391a030e683572eee01291cc8bc6203dbf5d;p=ghc-hetmet.git

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index f1328e0..d0a8a86 100644
--- 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,
@@ -22,7 +22,7 @@ module ErrUtils (
         mkDumpDoc, dumpSDoc,
 
 	--  * Messages during compilation
-	putMsg,
+        putMsg, putMsgWith,
 	errorMsg,
 	fatalErrorMsg,
 	compilationProgressMsg,
@@ -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 = 
@@ -302,6 +275,12 @@ ifVerbose dflags val act
 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
 
@@ -310,7 +289,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