From 1246293616fc45787ecaed13aa31a2555510f7e3 Mon Sep 17 00:00:00 2001 From: Thomas Schilling Date: Sat, 22 Nov 2008 13:06:58 +0000 Subject: [PATCH] Change 'handleFlagWarnings' to throw exceptions instead of dying. It now uses the standard warning log and error reporting mechanism. --- compiler/ghci/InteractiveUI.hs | 6 +++--- compiler/main/DriverPipeline.hs | 2 +- compiler/main/ErrUtils.lhs | 20 -------------------- compiler/main/GHC.hs | 4 ++-- compiler/main/HscTypes.lhs | 26 +++++++++++++++++++++++--- ghc/Main.hs | 6 +++++- 6 files changed, 34 insertions(+), 30 deletions(-) diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 059d692..4741a61 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 -- 1.7.10.4