Commit 12462936 authored by Thomas Schilling's avatar Thomas Schilling

Change 'handleFlagWarnings' to throw exceptions instead of dying.

It now uses the standard warning log and error reporting mechanism.
parent 34837046
...@@ -34,7 +34,8 @@ import PackageConfig ...@@ -34,7 +34,8 @@ import PackageConfig
import UniqFM import UniqFM
#endif #endif
import HscTypes ( implicitTyThings, reflectGhc, reifyGhc ) import HscTypes ( implicitTyThings, reflectGhc, reifyGhc
, handleFlagWarnings )
import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC? import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
import Outputable hiding (printForUser, printForUserPartWay) import Outputable hiding (printForUser, printForUserPartWay)
import Module -- for ModuleEnv import Module -- for ModuleEnv
...@@ -42,7 +43,6 @@ import Name ...@@ -42,7 +43,6 @@ import Name
import SrcLoc import SrcLoc
-- Other random utilities -- Other random utilities
import ErrUtils
import CmdLineParser import CmdLineParser
import Digraph import Digraph
import BasicTypes hiding (isTopLevel) import BasicTypes hiding (isTopLevel)
...@@ -1512,7 +1512,7 @@ newDynFlags minus_opts = do ...@@ -1512,7 +1512,7 @@ newDynFlags minus_opts = do
dflags <- getDynFlags dflags <- getDynFlags
let pkg_flags = packageFlags dflags let pkg_flags = packageFlags dflags
(dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
io $ handleFlagWarnings dflags' warns handleFlagWarnings dflags' warns
if (not (null leftovers)) if (not (null leftovers))
then ghcError $ errorsToGhcException leftovers then ghcError $ errorsToGhcException leftovers
......
...@@ -666,7 +666,7 @@ runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc ...@@ -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 src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
(dflags, unhandled_flags, warns) (dflags, unhandled_flags, warns)
<- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
liftIO $ handleFlagWarnings dflags warns -- XXX: may exit the program handleFlagWarnings dflags warns
checkProcessArgsResult unhandled_flags checkProcessArgsResult unhandled_flags
if not (dopt Opt_Cpp dflags) then if not (dopt Opt_Cpp dflags) then
......
...@@ -14,7 +14,6 @@ module ErrUtils ( ...@@ -14,7 +14,6 @@ module ErrUtils (
Messages, errorsFound, emptyMessages, Messages, errorsFound, emptyMessages,
mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg, mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings, printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
handleFlagWarnings,
warnIsErrorMsg, warnIsErrorMsg,
ghcExit, ghcExit,
...@@ -177,25 +176,6 @@ printBagOfWarnings dflags bag_of_warns ...@@ -177,25 +176,6 @@ printBagOfWarnings dflags bag_of_warns
EQ -> True EQ -> True
GT -> False 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 :: DynFlags -> Int -> IO ()
ghcExit dflags val ghcExit dflags val
| val == 0 = exitWith ExitSuccess | val == 0 = exitWith ExitSuccess
......
...@@ -2215,8 +2215,8 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) ...@@ -2215,8 +2215,8 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
-- --
(dflags', leftovers, warns) (dflags', leftovers, warns)
<- parseDynamicNoPackageFlags dflags local_opts <- parseDynamicNoPackageFlags dflags local_opts
liftIO $ checkProcessArgsResult leftovers -- XXX: throws exceptions checkProcessArgsResult leftovers
liftIO $ handleFlagWarnings dflags' warns -- XXX: throws exceptions handleFlagWarnings dflags' warns
let let
needs_preprocessing needs_preprocessing
......
...@@ -15,6 +15,7 @@ module HscTypes ( ...@@ -15,6 +15,7 @@ module HscTypes (
SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr, SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr,
throwOneError, handleSourceError, throwOneError, handleSourceError,
reflectGhc, reifyGhc, reflectGhc, reifyGhc,
handleFlagWarnings,
-- * Sessions and compilation state -- * Sessions and compilation state
Session(..), withSession, modifySession, Session(..), withSession, modifySession,
...@@ -131,7 +132,8 @@ import TyCon ...@@ -131,7 +132,8 @@ import TyCon
import DataCon ( DataCon, dataConImplicitIds, dataConWrapId ) import DataCon ( DataCon, dataConImplicitIds, dataConWrapId )
import PrelNames ( gHC_PRIM ) import PrelNames ( gHC_PRIM )
import Packages hiding ( Version(..) ) import Packages hiding ( Version(..) )
import DynFlags ( DynFlags(..), isOneShot, HscTarget (..) ) import DynFlags ( DynFlags(..), isOneShot, HscTarget (..), dopt,
DynFlag(..) )
import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase )
import BasicTypes ( IPName, Fixity, defaultFixity, WarningTxt(..) ) import BasicTypes ( IPName, Fixity, defaultFixity, WarningTxt(..) )
import OptimizationFuel ( OptFuelState ) import OptimizationFuel ( OptFuelState )
...@@ -141,7 +143,7 @@ import CoreSyn ( CoreRule ) ...@@ -141,7 +143,7 @@ import CoreSyn ( CoreRule )
import Maybes ( orElse, expectJust, catMaybes ) import Maybes ( orElse, expectJust, catMaybes )
import Outputable import Outputable
import BreakArray import BreakArray
import SrcLoc ( SrcSpan, Located ) import SrcLoc ( SrcSpan, Located(..) )
import LazyUniqFM ( lookupUFM, eltsUFM, emptyUFM ) import LazyUniqFM ( lookupUFM, eltsUFM, emptyUFM )
import UniqSupply ( UniqSupply ) import UniqSupply ( UniqSupply )
import FastString import FastString
...@@ -158,7 +160,7 @@ import System.Time ( ClockTime ) ...@@ -158,7 +160,7 @@ import System.Time ( ClockTime )
import Data.IORef import Data.IORef
import Data.Array ( Array, array ) import Data.Array ( Array, array )
import Data.List import Data.List
import Control.Monad ( mplus, guard, liftM ) import Control.Monad ( mplus, guard, liftM, when )
import Exception import Exception
\end{code} \end{code}
...@@ -409,6 +411,24 @@ reflectGhc m = unGhc m ...@@ -409,6 +411,24 @@ reflectGhc m = unGhc m
-- > Dual to 'reflectGhc'. See its documentation. -- > Dual to 'reflectGhc'. See its documentation.
reifyGhc :: (Session -> IO a) -> Ghc a reifyGhc :: (Session -> IO a) -> Ghc a
reifyGhc act = Ghc $ act 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} \end{code}
\begin{code} \begin{code}
......
...@@ -153,7 +153,11 @@ main = ...@@ -153,7 +153,11 @@ main =
let flagWarnings = staticFlagWarnings let flagWarnings = staticFlagWarnings
++ modeFlagWarnings ++ modeFlagWarnings
++ dynamicFlagWarnings ++ 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 -- make sure we clean up after ourselves
GHC.defaultCleanupHandler dflags2 $ do GHC.defaultCleanupHandler dflags2 $ do
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment