Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
12462936
Commit
12462936
authored
Nov 22, 2008
by
Thomas Schilling
Browse files
Change 'handleFlagWarnings' to throw exceptions instead of dying.
It now uses the standard warning log and error reporting mechanism.
parent
34837046
Changes
6
Hide whitespace changes
Inline
Side-by-side
compiler/ghci/InteractiveUI.hs
View file @
12462936
...
...
@@ -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
View file @
12462936
...
...
@@ -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
View file @
12462936
...
...
@@ -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
View file @
12462936
...
...
@@ -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
View file @
12462936
...
...
@@ -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
View file @
12462936
...
...
@@ -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
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment