Remove code that isn't used now that we assume that GHC >= 6.4

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

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index 72d0e93..d6cb5d0 100644 (file)
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -13,6 +13,7 @@ module ErrUtils (
        Messages, errorsFound, emptyMessages,
        mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg,
        printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
+    handleFlagWarnings,
 
        ghcExit,
        doIfSet, doIfSet_dyn, 
@@ -28,8 +29,6 @@ module ErrUtils (
        debugTraceMsg,  
     ) where
 
--- XXX This define is a bit of a hack, and should be done more nicely
-#define FAST_STRING_NOT_NEEDED 1
 #include "HsVersions.h"
 
 import Bag             ( Bag, bagToList, isEmptyBag, emptyBag )
@@ -40,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
@@ -86,11 +86,7 @@ errMsgTc :: TyCon
 errMsgTc = mkTyCon "ErrMsg"
 {-# NOINLINE errMsgTc #-}
 instance Typeable ErrMsg where
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603
-  typeOf _ = mkAppTy errMsgTc []
-#else
   typeOf _ = mkTyConApp errMsgTc []
-#endif
 
 type WarnMsg = ErrMsg
 
@@ -128,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
@@ -172,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