Change 'handleFlagWarnings' to throw exceptions instead of dying.

It now uses the standard warning log and error reporting mechanism.

compiler/ghci/InteractiveUI.hs

@@ -34,7 +34,8 @@ import PackageConfig
 import UniqFM
 #endif
 
-import HscTypes		( implicitTyThings, reflectGhc, reifyGhc )
+import HscTypes		( implicitTyThings, reflectGhc, reifyGhc
+                        , handleFlagWarnings )
 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
 import Outputable       hiding (printForUser, printForUserPartWay)
 import Module           -- for ModuleEnv
@@ -42,7 +43,6 @@ import Name
 import SrcLoc
 
 -- Other random utilities
-import ErrUtils
 import CmdLineParser
 import Digraph
 import BasicTypes hiding (isTopLevel)
@@ -1512,7 +1512,7 @@ newDynFlags minus_opts = do
       dflags <- getDynFlags
       let pkg_flags = packageFlags dflags
       (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
-      io $ handleFlagWarnings dflags' warns
+      handleFlagWarnings dflags' warns
 
       if (not (null leftovers))
         then ghcError $ errorsToGhcException leftovers

compiler/main/DriverPipeline.hs

@@ -666,7 +666,7 @@ runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
        src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
        (dflags, unhandled_flags, warns)
            <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
-       liftIO $ handleFlagWarnings dflags warns  -- XXX: may exit the program
+       handleFlagWarnings dflags warns
        checkProcessArgsResult unhandled_flags
 
        if not (dopt Opt_Cpp dflags) then

compiler/main/ErrUtils.lhs

@@ -14,7 +14,6 @@ module ErrUtils (
 	Messages, errorsFound, emptyMessages,
 	mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
 	printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
-    handleFlagWarnings,
 	warnIsErrorMsg,
 
 	ghcExit,
@@ -177,25 +176,6 @@ 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
   | val == 0  = exitWith ExitSuccess

compiler/main/GHC.hs

@@ -2215,8 +2215,8 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
 	--
 	(dflags', leftovers, warns)
             <- parseDynamicNoPackageFlags dflags local_opts
-        liftIO $ checkProcessArgsResult leftovers -- XXX: throws exceptions
-        liftIO $ handleFlagWarnings dflags' warns -- XXX: throws exceptions
+        checkProcessArgsResult leftovers
+        handleFlagWarnings dflags' warns
 
 	let
 	    needs_preprocessing

compiler/main/HscTypes.lhs

@@ -15,6 +15,7 @@ module HscTypes (
         SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr,
         throwOneError, handleSourceError,
         reflectGhc, reifyGhc,
+        handleFlagWarnings,
 
 	-- * Sessions and compilation state
 	Session(..), withSession, modifySession,
@@ -131,7 +132,8 @@ import TyCon
 import DataCon		( DataCon, dataConImplicitIds, dataConWrapId )
 import PrelNames	( gHC_PRIM )
 import Packages hiding ( Version(..) )
-import DynFlags		( DynFlags(..), isOneShot, HscTarget (..) )
+import DynFlags		( DynFlags(..), isOneShot, HscTarget (..), dopt,
+                          DynFlag(..) )
 import DriverPhases	( HscSource(..), isHsBoot, hscSourceString, Phase )
 import BasicTypes	( IPName, Fixity, defaultFixity, WarningTxt(..) )
 import OptimizationFuel	( OptFuelState )
@@ -141,7 +143,7 @@ import CoreSyn		( CoreRule )
 import Maybes		( orElse, expectJust, catMaybes )
 import Outputable
 import BreakArray
-import SrcLoc		( SrcSpan, Located )
+import SrcLoc		( SrcSpan, Located(..) )
 import LazyUniqFM		( lookupUFM, eltsUFM, emptyUFM )
 import UniqSupply	( UniqSupply )
 import FastString
@@ -158,7 +160,7 @@ import System.Time	( ClockTime )
 import Data.IORef
 import Data.Array       ( Array, array )
 import Data.List
-import Control.Monad    ( mplus, guard, liftM )
+import Control.Monad    ( mplus, guard, liftM, when )
 import Exception
 \end{code}
 
@@ -409,6 +411,24 @@ reflectGhc m = unGhc m
 -- > Dual to 'reflectGhc'.  See its documentation.
 reifyGhc :: (Session -> IO a) -> Ghc a
 reifyGhc act = Ghc $ act
+
+handleFlagWarnings :: GhcMonad m => DynFlags -> [Located String] -> m ()
+handleFlagWarnings dflags warns
+ = when (dopt Opt_WarnDeprecatedFlags dflags)
+        (handleFlagWarnings' dflags warns)
+
+handleFlagWarnings' :: GhcMonad m => DynFlags -> [Located String] -> m ()
+handleFlagWarnings' _ [] = return ()
+handleFlagWarnings' dflags warns
+ = do -- It would be nicer if warns :: [Located Message], but that has circular
+      -- import problems.
+      logWarnings $ listToBag (map mkFlagWarning warns)
+      when (dopt Opt_WarnIsError dflags) $
+        liftIO $ throwIO $ mkSrcErr emptyBag
+
+mkFlagWarning :: Located String -> WarnMsg
+mkFlagWarning (L loc warn)
+ = mkPlainWarnMsg loc (text warn)
 \end{code}
 
 \begin{code}

ghc/Main.hs

@@ -153,7 +153,11 @@ main =
   let flagWarnings = staticFlagWarnings
                   ++ modeFlagWarnings
                   ++ dynamicFlagWarnings
-  liftIO $ handleFlagWarnings dflags2 flagWarnings
+
+  handleSourceError (\e -> do
+       GHC.printExceptionAndWarnings e
+       liftIO $ exitWith (ExitFailure 1)) $
+    handleFlagWarnings dflags2 flagWarnings
 
         -- make sure we clean up after ourselves
   GHC.defaultCleanupHandler dflags2 $ do