Change 'handleFlagWarnings' to throw exceptions instead of dying.

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

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index 059d692..4741a61 100644 (file)
--- a/compiler/ghci/InteractiveUI.hs
+++ b/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

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 2bf19b9..3a88318 100644 (file)
--- a/compiler/main/DriverPipeline.hs
+++ b/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

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index d37dba9..9159a3e 100644 (file)
--- a/compiler/main/ErrUtils.lhs
+++ b/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

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index d45109f..29bb4f7 100644 (file)
--- a/compiler/main/GHC.hs
+++ b/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

diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 22f5a9c..76e28be 100644 (file)
--- a/compiler/main/HscTypes.lhs
+++ b/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}

diff --git a/ghc/Main.hs b/ghc/Main.hs
index 766577e..06a5ceb 100644 (file)
--- a/ghc/Main.hs
+++ b/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