X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FErrUtils.lhs;h=18e7337ba96640c810c06017aaa472bc476fa773;hb=c2d0219ac359355d60d6ffac381e4051d79ad729;hp=455b3bfe37a3fe78f6468e58906c9aa4a8f2e5cd;hpb=c1efc06cb56bc4359622918c5354b5730ea37724;p=ghc-hetmet.git

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index 455b3bf..18e7337 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -8,11 +8,12 @@ module ErrUtils (
 	Message, mkLocMessage, printError,
 	Severity(..),
 
-	ErrMsg, WarnMsg,
+	ErrMsg, WarnMsg, throwErrMsg, handleErrMsg,
 	errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
 	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 )
@@ -45,6 +44,7 @@ import System.Exit	( ExitCode(..), exitWith )
 import Data.Dynamic
 import Data.List
 import System.IO
+import Exception
 
 -- -----------------------------------------------------------------------------
 -- Basic error messages: just render a message with a source location.
@@ -82,16 +82,33 @@ data ErrMsg = ErrMsg {
 	-- NB  Pretty.Doc not SDoc: we deal with the printing style (in ptic 
 	-- whether to qualify an External Name) at the error occurrence
 
+#if __GLASGOW_HASKELL__ >= 609
+instance Exception ErrMsg
+#endif
+
+instance Show ErrMsg where
+    show em = showSDoc (errMsgShortDoc em)
+
+throwErrMsg :: ErrMsg -> a
+#if __GLASGOW_HASKELL__ < 609
+throwErrMsg = throwDyn
+#else
+throwErrMsg = throw
+#endif
+
+handleErrMsg :: (ErrMsg -> IO a) -> IO a -> IO a
+#if __GLASGOW_HASKELL__ < 609
+handleErrMsg = flip catchDyn
+#else
+handleErrMsg = handle
+#endif
+
 -- So we can throw these things as exceptions
 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
 
@@ -122,7 +139,7 @@ emptyMessages = (emptyBag, emptyBag)
 
 errorsFound :: DynFlags -> Messages -> Bool
 -- The dyn-flags are used to see if the user has specified
--- -Werorr, which says that warnings should be fatal
+-- -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)
@@ -176,7 +193,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