X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FErrUtils.lhs;h=d6cb5d0226bd39a75f3a0fc648793e9fcf8600cc;hb=e761a777f2440ca1b8d8b40848cc5aa30d889ff6;hp=cee03cce3b5b3a4f00981bee822f119a4aad1f55;hpb=ad94d40948668032189ad22a0ad741ac1f645f50;p=ghc-hetmet.git

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index cee03cc..d6cb5d0 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -4,13 +4,6 @@
 \section[ErrsUtils]{Utilities for error reporting}
 
 \begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
--- for details
-
 module ErrUtils (
 	Message, mkLocMessage, printError,
 	Severity(..),
@@ -20,10 +13,12 @@ module ErrUtils (
 	Messages, errorsFound, emptyMessages,
 	mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg,
 	printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
+    handleFlagWarnings,
 
 	ghcExit,
 	doIfSet, doIfSet_dyn, 
-	dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc, dumpSDoc,
+	dumpIfSet, dumpIf_core, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or,
+        mkDumpDoc, dumpSDoc,
 
 	--  * Messages during compilation
 	putMsg,
@@ -36,7 +31,6 @@ module ErrUtils (
 
 #include "HsVersions.h"
 
-import Module		( ModLocation(..))
 import Bag		( Bag, bagToList, isEmptyBag, emptyBag )
 import SrcLoc		( SrcSpan )
 import Util		( sortLe )
@@ -45,6 +39,7 @@ import SrcLoc		( srcSpanStart, noSrcSpan )
 import DynFlags		( DynFlags(..), DynFlag(..), dopt )
 import StaticFlags	( opt_ErrorSpans )
 
+import Control.Monad
 import System.Exit	( ExitCode(..), exitWith )
 import Data.Dynamic
 import Data.List
@@ -91,11 +86,7 @@ errMsgTc :: TyCon
 errMsgTc = mkTyCon "ErrMsg"
 {-# NOINLINE errMsgTc #-}
 instance Typeable ErrMsg where
-#if __GLASGOW_HASKELL__ < 603
-  typeOf _ = mkAppTy errMsgTc []
-#else
   typeOf _ = mkTyConApp errMsgTc []
-#endif
 
 type WarnMsg = ErrMsg
 
@@ -133,10 +124,13 @@ errorsFound dflags (warns, errs)
 
 printErrorsAndWarnings :: DynFlags -> Messages -> IO ()
 printErrorsAndWarnings dflags (warns, errs)
-  | no_errs && no_warns  = return ()
-  | no_errs		 = printBagOfWarnings dflags warns
-			    -- Don't print any warnings if there are errors
-  | otherwise		 = printBagOfErrors   dflags 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
@@ -145,7 +139,7 @@ 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:ss,
+		| ErrMsg { errMsgSpans = s:_,
 			   errMsgShortDoc = d,
 			   errMsgExtraInfo = e,
 			   errMsgContext = unqual } <- sorted_errs ]
@@ -163,7 +157,7 @@ printBagOfWarnings :: DynFlags -> Bag ErrMsg -> IO ()
 printBagOfWarnings dflags bag_of_warns
   = sequence_   [ let style = mkErrStyle unqual
 		  in log_action dflags SevWarning s style (d $$ e)
-		| ErrMsg { errMsgSpans = s:ss,
+		| ErrMsg { errMsgSpans = s:_,
 			   errMsgShortDoc = d,
 			   errMsgExtraInfo = e,
 			   errMsgContext = unqual } <- sorted_errs ]
@@ -177,7 +171,21 @@ printBagOfWarnings dflags bag_of_warns
 		EQ -> True
 		GT -> False
 
-
+handleFlagWarnings :: DynFlags -> [String] -> IO ()
+handleFlagWarnings dflags warns
+ = when (dopt Opt_WarnDeprecatedFlags dflags)
+        (handleFlagWarnings' dflags warns)
+
+handleFlagWarnings' :: DynFlags -> [String] -> IO ()
+handleFlagWarnings' _ [] = return ()
+handleFlagWarnings' dflags warns
+ = do -- It would be nicer if warns :: [Message], but that has circular
+      -- import problems.
+      let warns' = map text warns
+      mapM_ (log_action dflags SevWarning noSrcSpan defaultUserStyle) warns'
+      when (dopt Opt_WarnIsError dflags) $
+          do errorMsg dflags $ text "\nFailing due to -Werror.\n"
+             exitWith (ExitFailure 1)
 
 ghcExit :: DynFlags -> Int -> IO ()
 ghcExit dflags val
@@ -201,13 +209,18 @@ 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
-  | dopt flag dflags
-	|| verbosity dflags >= 4
-	|| dopt Opt_D_verbose_core2core dflags
-  = dumpSDoc dflags flag hdr doc
-  | otherwise                                   = return ()
+  = dumpIf_core (dopt flag dflags) dflags flag hdr doc
 
 dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 dumpIfSet_dyn dflags flag hdr doc
@@ -223,6 +236,7 @@ dumpIfSet_dyn_or dflags flags hdr doc
   = printDump (mkDumpDoc hdr doc)
   | otherwise = return ()
 
+mkDumpDoc :: String -> SDoc -> SDoc
 mkDumpDoc hdr doc 
    = vcat [text "", 
 	   line <+> text hdr <+> line,