X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FErrUtils.lhs;h=d37dba9ecfd9ec4128fd4c8ff5baa55a092f07e6;hb=c0ac8b6b2192d296fc28bfc8eb566123e8d72bf0;hp=8b3af12207957cf188c14e93f87f97787406e93e;hpb=f2cd56cf9fc310c9b587ecb5dfaee4ad6b580355;p=ghc-hetmet.git

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index 8b3af12..d37dba9 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -9,14 +9,18 @@ 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,
+    handleFlagWarnings,
+	warnIsErrorMsg,
 
 	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,
@@ -29,17 +33,15 @@ module ErrUtils (
 
 #include "HsVersions.h"
 
-import Module		( ModLocation(..))
 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
 
@@ -79,16 +81,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 __GLASGOW_HASKELL__ < 603
-  typeOf _ = mkAppTy errMsgTc []
-#else
-  typeOf _ = mkTyConApp errMsgTc []
-#endif
+instance Show ErrMsg where
+    show em = showSDoc (errMsgShortDoc em)
 
 type WarnMsg = ErrMsg
 
@@ -112,24 +106,37 @@ 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)
 
 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
@@ -138,7 +145,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 ]
@@ -156,7 +163,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 ]
@@ -170,7 +177,24 @@ printBagOfWarnings dflags bag_of_warns
 		EQ -> True
 		GT -> False
 
-
+handleFlagWarnings :: DynFlags -> [Located String] -> IO ()
+handleFlagWarnings dflags warns
+ = when (dopt Opt_WarnDeprecatedFlags dflags)
+        (handleFlagWarnings' dflags warns)
+
+handleFlagWarnings' :: DynFlags -> [Located String] -> IO ()
+handleFlagWarnings' _ [] = return ()
+handleFlagWarnings' dflags warns
+ = do -- It would be nicer if warns :: [Located Message], but that has circular
+      -- import problems.
+      mapM_ (handleFlagWarning dflags) warns
+      when (dopt Opt_WarnIsError dflags) $
+          do errorMsg dflags $ text "\nFailing due to -Werror.\n"
+             exitWith (ExitFailure 1)
+
+handleFlagWarning :: DynFlags -> Located String -> IO ()
+handleFlagWarning dflags (L loc warn)
+ = log_action dflags SevWarning loc defaultUserStyle (text warn)
 
 ghcExit :: DynFlags -> Int -> IO ()
 ghcExit dflags val
@@ -194,13 +218,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
@@ -216,6 +245,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,