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

-- | Converts a list of 'WarningMessages' into a tuple where the second element contains only
-- error, i.e. warnings that are considered fatal by GHC based on the input 'DynFlags'.
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

      -- It would be nicer if warns :: [Located SDoc], but that
      -- has circular import problems.
      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

-- | Checks if given 'WarnMsg' is a fatal warning.
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

-- Given a warn reason, check to see if it's associated -W opt is enabled
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

-- | Given a bag of warnings, turn them into an exception if
-- -Werror is enabled, or print them out otherwise.
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