module GHC.Driver.Errors (
warningsToMessages
, printOrThrowWarnings
, printBagOfErrors
, isWarnMsgFatal
, handleFlagWarnings
) where
import GHC.Driver.Session
import GHC.Data.Bag
import GHC.Utils.Exception
import GHC.Utils.Error ( formatBulleted, sortMsgBag )
import GHC.Types.SourceError ( mkSrcErr )
import GHC.Prelude
import GHC.Types.SrcLoc
import GHC.Types.Error
import GHC.Utils.Outputable ( text, withPprStyle, mkErrStyle )
import GHC.Utils.Logger
import qualified GHC.Driver.CmdLine as CmdLine
warningsToMessages :: DynFlags -> WarningMessages -> (WarningMessages, ErrorMessages)
warningsToMessages :: DynFlags -> WarningMessages -> (WarningMessages, WarningMessages)
warningsToMessages DynFlags
dflags =
forall a b c. (a -> Either b c) -> Bag a -> (Bag b, Bag c)
partitionBagWith forall a b. (a -> b) -> a -> b
$ \MsgEnvelope DecoratedSDoc
warn ->
case DynFlags -> MsgEnvelope DecoratedSDoc -> Maybe (Maybe WarningFlag)
isWarnMsgFatal DynFlags
dflags MsgEnvelope DecoratedSDoc
warn of
Maybe (Maybe WarningFlag)
Nothing -> forall a b. a -> Either a b
Left MsgEnvelope DecoratedSDoc
warn
Just Maybe WarningFlag
err_reason ->
forall a b. b -> Either a b
Right MsgEnvelope DecoratedSDoc
warn{ errMsgSeverity :: Severity
errMsgSeverity = Severity
SevError
, errMsgReason :: WarnReason
errMsgReason = Maybe WarningFlag -> WarnReason
ErrReason Maybe WarningFlag
err_reason }
printBagOfErrors :: RenderableDiagnostic a => Logger -> DynFlags -> Bag (MsgEnvelope a) -> IO ()
printBagOfErrors :: forall a.
RenderableDiagnostic a =>
Logger -> DynFlags -> Bag (MsgEnvelope a) -> IO ()
printBagOfErrors Logger
logger DynFlags
dflags Bag (MsgEnvelope a)
bag_of_errors
= forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ let style :: PprStyle
style = PrintUnqualified -> PprStyle
mkErrStyle PrintUnqualified
unqual
ctx :: SDocContext
ctx = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
style
in Logger -> LogAction
putLogMsg Logger
logger DynFlags
dflags WarnReason
reason Severity
sev SrcSpan
s forall a b. (a -> b) -> a -> b
$
PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
style (SDocContext -> DecoratedSDoc -> SDoc
formatBulleted SDocContext
ctx (forall a. RenderableDiagnostic a => a -> DecoratedSDoc
renderDiagnostic a
doc))
| MsgEnvelope { errMsgSpan :: forall e. MsgEnvelope e -> SrcSpan
errMsgSpan = SrcSpan
s,
errMsgDiagnostic :: forall e. MsgEnvelope e -> e
errMsgDiagnostic = a
doc,
errMsgSeverity :: forall e. MsgEnvelope e -> Severity
errMsgSeverity = Severity
sev,
errMsgReason :: forall e. MsgEnvelope e -> WarnReason
errMsgReason = WarnReason
reason,
errMsgContext :: forall e. MsgEnvelope e -> PrintUnqualified
errMsgContext = PrintUnqualified
unqual } <- forall e. Maybe DynFlags -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
sortMsgBag (forall a. a -> Maybe a
Just DynFlags
dflags)
Bag (MsgEnvelope a)
bag_of_errors ]
handleFlagWarnings :: Logger -> DynFlags -> [CmdLine.Warn] -> IO ()
handleFlagWarnings :: Logger -> DynFlags -> [Warn] -> IO ()
handleFlagWarnings Logger
logger DynFlags
dflags [Warn]
warns = do
let warns' :: [Warn]
warns' = forall a. (a -> Bool) -> [a] -> [a]
filter (DynFlags -> WarnReason -> Bool
shouldPrintWarning DynFlags
dflags forall b c a. (b -> c) -> (a -> b) -> a -> c
. Warn -> WarnReason
CmdLine.warnReason) [Warn]
warns
toWarnReason :: WarnReason -> WarnReason
toWarnReason WarnReason
CmdLine.ReasonDeprecatedFlag = WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnDeprecatedFlags
toWarnReason WarnReason
CmdLine.ReasonUnrecognisedFlag = WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnUnrecognisedWarningFlags
toWarnReason WarnReason
CmdLine.NoReason = WarnReason
NoReason
bag :: WarningMessages
bag = forall a. [a] -> Bag a
listToBag [ forall e. WarnReason -> MsgEnvelope e -> MsgEnvelope e
makeIntoWarning (WarnReason -> WarnReason
toWarnReason WarnReason
reason) (SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainWarnMsg SrcSpan
loc (String -> SDoc
text String
warn))
| CmdLine.Warn WarnReason
reason (L SrcSpan
loc String
warn) <- [Warn]
warns' ]
Logger -> DynFlags -> WarningMessages -> IO ()
printOrThrowWarnings Logger
logger DynFlags
dflags WarningMessages
bag
isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag)
isWarnMsgFatal :: DynFlags -> MsgEnvelope DecoratedSDoc -> Maybe (Maybe WarningFlag)
isWarnMsgFatal DynFlags
dflags MsgEnvelope{errMsgReason :: forall e. MsgEnvelope e -> WarnReason
errMsgReason = Reason WarningFlag
wflag}
= if WarningFlag -> DynFlags -> Bool
wopt_fatal WarningFlag
wflag DynFlags
dflags
then forall a. a -> Maybe a
Just (forall a. a -> Maybe a
Just WarningFlag
wflag)
else forall a. Maybe a
Nothing
isWarnMsgFatal DynFlags
dflags MsgEnvelope DecoratedSDoc
_
= if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WarnIsError DynFlags
dflags
then forall a. a -> Maybe a
Just forall a. Maybe a
Nothing
else forall a. Maybe a
Nothing
shouldPrintWarning :: DynFlags -> CmdLine.WarnReason -> Bool
shouldPrintWarning :: DynFlags -> WarnReason -> Bool
shouldPrintWarning DynFlags
dflags WarnReason
CmdLine.ReasonDeprecatedFlag
= WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnDeprecatedFlags DynFlags
dflags
shouldPrintWarning DynFlags
dflags WarnReason
CmdLine.ReasonUnrecognisedFlag
= WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnUnrecognisedWarningFlags DynFlags
dflags
shouldPrintWarning DynFlags
_ WarnReason
_
= Bool
True
printOrThrowWarnings :: Logger -> DynFlags -> Bag WarnMsg -> IO ()
printOrThrowWarnings :: Logger -> DynFlags -> WarningMessages -> IO ()
printOrThrowWarnings Logger
logger DynFlags
dflags WarningMessages
warns = do
let (Bool
make_error, WarningMessages
warns') =
forall acc x y.
(acc -> x -> (acc, y)) -> acc -> Bag x -> (acc, Bag y)
mapAccumBagL
(\Bool
make_err MsgEnvelope DecoratedSDoc
warn ->
case DynFlags -> MsgEnvelope DecoratedSDoc -> Maybe (Maybe WarningFlag)
isWarnMsgFatal DynFlags
dflags MsgEnvelope DecoratedSDoc
warn of
Maybe (Maybe WarningFlag)
Nothing ->
(Bool
make_err, MsgEnvelope DecoratedSDoc
warn)
Just Maybe WarningFlag
err_reason ->
(Bool
True, MsgEnvelope DecoratedSDoc
warn{ errMsgSeverity :: Severity
errMsgSeverity = Severity
SevError
, errMsgReason :: WarnReason
errMsgReason = Maybe WarningFlag -> WarnReason
ErrReason Maybe WarningFlag
err_reason
}))
Bool
False WarningMessages
warns
if Bool
make_error
then forall e a. Exception e => e -> IO a
throwIO (WarningMessages -> SourceError
mkSrcErr WarningMessages
warns')
else forall a.
RenderableDiagnostic a =>
Logger -> DynFlags -> Bag (MsgEnvelope a) -> IO ()
printBagOfErrors Logger
logger DynFlags
dflags WarningMessages
warns