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

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index af1da39..dd7f2ac 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -8,12 +8,12 @@ module ErrUtils (
 	Message, mkLocMessage, printError,
 	Severity(..),
 
-	ErrMsg, WarnMsg, throwErrMsg, handleErrMsg,
-	errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
+	ErrMsg, WarnMsg,
+        ErrorMessages, WarningMessages,
 	Messages, errorsFound, emptyMessages,
 	mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
 	printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
-    handleFlagWarnings,
+	warnIsErrorMsg,
 
 	ghcExit,
 	doIfSet, doIfSet_dyn, 
@@ -32,19 +32,16 @@ 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 )
 
 import Control.Monad
 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.
@@ -79,55 +76,31 @@ data ErrMsg = ErrMsg {
 	errMsgExtraInfo :: Message
 	}
 	-- The SrcSpan is used for sorting errors into line-number order
-	-- 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
-  typeOf _ = mkTyConApp errMsgTc []
-
 type WarnMsg = ErrMsg
 
 -- A short (one-line) error message, with context to tell us whether
 -- to qualify names in the message or not.
 mkErrMsg :: SrcSpan -> PrintUnqualified -> Message -> ErrMsg
 mkErrMsg locn print_unqual msg
-  = ErrMsg [locn] print_unqual msg empty
+  = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual
+           , errMsgShortDoc = msg, errMsgExtraInfo = empty }
 
 -- Variant that doesn't care about qualified/unqualified names
 mkPlainErrMsg :: SrcSpan -> Message -> ErrMsg
 mkPlainErrMsg locn msg
-  = ErrMsg [locn] alwaysQualify msg empty
+  = ErrMsg { errMsgSpans = [locn], errMsgContext = alwaysQualify
+           , errMsgShortDoc = msg, errMsgExtraInfo = empty }
 
 -- A long (multi-line) error message, with context to tell us whether
 -- to qualify names in the message or not.
 mkLongErrMsg :: SrcSpan -> PrintUnqualified -> Message -> Message -> ErrMsg
 mkLongErrMsg locn print_unqual msg extra 
- = ErrMsg [locn] print_unqual msg extra
+ = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual
+          , errMsgShortDoc = msg, errMsgExtraInfo = extra }
 
 mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg
 mkWarnMsg = mkErrMsg
@@ -138,9 +111,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 +176,6 @@ 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
   | val == 0  = exitWith ExitSuccess