Messages, errorsFound, emptyMessages,
mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg,
printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
+ handleFlagWarnings,
ghcExit,
doIfSet, doIfSet_dyn,
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 DynFlags ( DynFlags(..), DynFlag(..), dopt )
import StaticFlags ( opt_ErrorSpans )
+import Control.Monad
import System.Exit ( ExitCode(..), exitWith )
import Data.Dynamic
import Data.List
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
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
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