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
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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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}
......
......@@ -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
......
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