X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FErrUtils.lhs;h=a0325bf8080c29d3f1ff60ba3f5bffec4ed464e6;hb=3a61d75c70f61a2b919e94e85ffe1166e7151b5b;hp=af1da394a3c7c6b3115d499f91fedd79433dd642;hpb=b034e785cac038b9ffa72bf73ccc45a12c40c812;p=ghc-hetmet.git

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index af1da39..a0325bf 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -9,11 +9,13 @@ module ErrUtils (
 	Severity(..),
 
 	ErrMsg, WarnMsg, throwErrMsg, handleErrMsg,
+    ErrorMessages, WarningMessages,
 	errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
 	Messages, errorsFound, emptyMessages,
 	mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
 	printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
     handleFlagWarnings,
+	warnIsErrorMsg,
 
 	ghcExit,
 	doIfSet, doIfSet_dyn, 
@@ -32,10 +34,9 @@ module ErrUtils (
 #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 )
 
@@ -138,9 +139,15 @@ 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
 -- -Werror, which says that warnings should be fatal
@@ -197,22 +204,25 @@ printBagOfWarnings dflags bag_of_warns
 		EQ -> True
 		GT -> False
 
-handleFlagWarnings :: DynFlags -> [String] -> IO ()
+handleFlagWarnings :: DynFlags -> [Located String] -> IO ()
 handleFlagWarnings dflags warns
  = when (dopt Opt_WarnDeprecatedFlags dflags)
         (handleFlagWarnings' dflags warns)
 
-handleFlagWarnings' :: DynFlags -> [String] -> IO ()
+handleFlagWarnings' :: DynFlags -> [Located String] -> IO ()
 handleFlagWarnings' _ [] = return ()
 handleFlagWarnings' dflags warns
- = do -- It would be nicer if warns :: [Message], but that has circular
+ = do -- It would be nicer if warns :: [Located Message], but that has circular
       -- import problems.
-      let warns' = map text warns
-      mapM_ (log_action dflags SevWarning noSrcSpan defaultUserStyle) warns'
+      mapM_ (handleFlagWarning dflags) warns
       when (dopt Opt_WarnIsError dflags) $
           do errorMsg dflags $ text "\nFailing due to -Werror.\n"
              exitWith (ExitFailure 1)
 
+handleFlagWarning :: DynFlags -> Located String -> IO ()
+handleFlagWarning dflags (L loc warn)
+ = log_action dflags SevWarning loc defaultUserStyle (text warn)
+
 ghcExit :: DynFlags -> Int -> IO ()
 ghcExit dflags val
   | val == 0  = exitWith ExitSuccess