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

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index 455b3bf..9159a3e 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -9,10 +9,12 @@ module ErrUtils (
 	Severity(..),
 
 	ErrMsg, WarnMsg,
+    ErrorMessages, WarningMessages,
 	errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
 	Messages, errorsFound, emptyMessages,
-	mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg,
+	mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
 	printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
+	warnIsErrorMsg,
 
 	ghcExit,
 	doIfSet, doIfSet_dyn, 
@@ -28,21 +30,17 @@ 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 )
-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
 
@@ -82,16 +80,8 @@ 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
 
--- 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
+instance Show ErrMsg where
+    show em = showSDoc (errMsgShortDoc em)
 
 type WarnMsg = ErrMsg
 
@@ -115,14 +105,24 @@ mkLongErrMsg locn print_unqual msg extra
 mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg
 mkWarnMsg = mkErrMsg
 
+-- Variant that doesn't care about qualified/unqualified names
+mkPlainWarnMsg :: SrcSpan -> Message -> ErrMsg
+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
--- -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,8 +176,6 @@ printBagOfWarnings dflags bag_of_warns
 		EQ -> True
 		GT -> False
 
-
-
 ghcExit :: DynFlags -> Int -> IO ()
 ghcExit dflags val
   | val == 0  = exitWith ExitSuccess