module GHC.Driver.Errors (
    printOrThrowDiagnostics
  , printMessages
  , handleFlagWarnings
  , mkDriverPsHeaderMessage
  ) where

import GHC.Driver.Errors.Types
import GHC.Data.Bag
import GHC.Prelude
import GHC.Types.SrcLoc
import GHC.Types.SourceError
import GHC.Types.Error
import GHC.Utils.Error
import GHC.Utils.Outputable (hang, ppr, ($$), SDocContext,  text, withPprStyle, mkErrStyle, sdocStyle )
import GHC.Utils.Logger
import qualified GHC.Driver.CmdLine as CmdLine

printMessages :: Diagnostic a => Logger -> DiagOpts -> Messages a -> IO ()
printMessages :: forall a. Diagnostic a => Logger -> DiagOpts -> Messages a -> IO ()
printMessages Logger
logger DiagOpts
opts Messages a
msgs
  = 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   = (DiagOpts -> SDocContext
diag_ppr_ctx DiagOpts
opts) { sdocStyle :: PprStyle
sdocStyle = PprStyle
style }
                in Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger (Severity -> DiagnosticReason -> MessageClass
MCDiagnostic Severity
sev forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Diagnostic a => a -> DiagnosticReason
diagnosticReason forall a b. (a -> b) -> a -> b
$ a
dia) SrcSpan
s forall a b. (a -> b) -> a -> b
$
                   PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
style (forall a. Diagnostic a => SDocContext -> a -> SDoc
messageWithHints SDocContext
ctx a
dia)
              | MsgEnvelope { errMsgSpan :: forall e. MsgEnvelope e -> SrcSpan
errMsgSpan      = SrcSpan
s,
                              errMsgDiagnostic :: forall e. MsgEnvelope e -> e
errMsgDiagnostic = a
dia,
                              errMsgSeverity :: forall e. MsgEnvelope e -> Severity
errMsgSeverity = Severity
sev,
                              errMsgContext :: forall e. MsgEnvelope e -> PrintUnqualified
errMsgContext   = PrintUnqualified
unqual } <- forall e. Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
sortMsgBag (forall a. a -> Maybe a
Just DiagOpts
opts)
                                                                       (forall e. Messages e -> Bag (MsgEnvelope e)
getMessages Messages a
msgs) ]
  where
    messageWithHints :: Diagnostic a => SDocContext -> a -> SDoc
    messageWithHints :: forall a. Diagnostic a => SDocContext -> a -> SDoc
messageWithHints SDocContext
ctx a
e =
      let main_msg :: SDoc
main_msg = SDocContext -> DecoratedSDoc -> SDoc
formatBulleted SDocContext
ctx forall a b. (a -> b) -> a -> b
$ forall a. Diagnostic a => a -> DecoratedSDoc
diagnosticMessage a
e
          in case forall a. Diagnostic a => a -> [GhcHint]
diagnosticHints a
e of
               []  -> SDoc
main_msg
               [GhcHint
h] -> SDoc
main_msg SDoc -> SDoc -> SDoc
$$ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Suggested fix:") Int
2 (forall a. Outputable a => a -> SDoc
ppr GhcHint
h)
               [GhcHint]
hs  -> SDoc
main_msg SDoc -> SDoc -> SDoc
$$ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Suggested fixes:") Int
2
                                       (SDocContext -> DecoratedSDoc -> SDoc
formatBulleted SDocContext
ctx forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> DecoratedSDoc
mkDecorated forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ [GhcHint]
hs)

handleFlagWarnings :: Logger -> DiagOpts -> [CmdLine.Warn] -> IO ()
handleFlagWarnings :: Logger -> DiagOpts -> [Warn] -> IO ()
handleFlagWarnings Logger
logger DiagOpts
opts [Warn]
warns = do
  let -- It would be nicer if warns :: [Located SDoc], but that
      -- has circular import problems.
      bag :: Bag (MsgEnvelope GhcMessage)
bag = forall a. [a] -> Bag a
listToBag [ forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
opts SrcSpan
loc forall a b. (a -> b) -> a -> b
$
                        DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$
                        forall a. (Diagnostic a, Typeable a) => a -> DriverMessage
DriverUnknownMessage forall a b. (a -> b) -> a -> b
$
                        DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic DiagnosticReason
reason [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
warn
                      | CmdLine.Warn DiagnosticReason
reason (L SrcSpan
loc String
warn) <- [Warn]
warns ]

  Logger -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics Logger
logger DiagOpts
opts (forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages Bag (MsgEnvelope GhcMessage)
bag)

-- | Given a bag of diagnostics, turn them into an exception if
-- any has 'SevError', or print them out otherwise.
printOrThrowDiagnostics :: Logger -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics :: Logger -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics Logger
logger DiagOpts
opts Messages GhcMessage
msgs
  | forall e. Messages e -> Bool
errorsOrFatalWarningsFound Messages GhcMessage
msgs
  = forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors Messages GhcMessage
msgs
  | Bool
otherwise
  = forall a. Diagnostic a => Logger -> DiagOpts -> Messages a -> IO ()
printMessages Logger
logger DiagOpts
opts Messages GhcMessage
msgs

-- | Convert a 'PsError' into a wrapped 'DriverMessage'; use it
-- for dealing with parse errors when the driver is doing dependency analysis.
-- Defined here to avoid module loops between GHC.Driver.Error.Types and
-- GHC.Driver.Error.Ppr
mkDriverPsHeaderMessage :: MsgEnvelope PsMessage -> MsgEnvelope DriverMessage
mkDriverPsHeaderMessage :: MsgEnvelope PsMessage -> MsgEnvelope DriverMessage
mkDriverPsHeaderMessage = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsMessage -> DriverMessage
DriverPsHeaderMessage