{-# LANGUAGE ScopedTypeVariables #-}
module GHC.Driver.Errors (
    printOrThrowDiagnostics
  , printMessages
  , mkDriverPsHeaderMessage
  ) where

import GHC.Driver.Errors.Types
import GHC.Prelude
import GHC.Types.SourceError
import GHC.Types.Error
import GHC.Utils.Error
import GHC.Utils.Outputable (hang, ppr, ($$),  text, mkErrStyle, sdocStyle, updSDocContext )
import GHC.Utils.Logger

printMessages :: forall a . Diagnostic a => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
printMessages :: forall a.
Diagnostic a =>
Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
printMessages Logger
logger DiagnosticOpts a
msg_opts DiagOpts
opts Messages a
msgs
  = [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ let style :: PprStyle
style = NamePprCtx -> PprStyle
mkErrStyle NamePprCtx
name_ppr_ctx
                    ctx :: SDocContext
ctx   = (DiagOpts -> SDocContext
diag_ppr_ctx DiagOpts
opts) { sdocStyle = style }
                in (if Bool
log_diags_as_json
                    then Logger -> MessageClass -> MsgEnvelope a -> IO ()
forall a. ToJson a => Logger -> MessageClass -> a -> IO ()
logJsonMsg Logger
logger (Severity
-> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> MessageClass
MCDiagnostic Severity
sev ResolvedDiagnosticReason
reason (a -> Maybe DiagnosticCode
forall a. Diagnostic a => a -> Maybe DiagnosticCode
diagnosticCode a
dia)) MsgEnvelope a
msg
                    else Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger (Severity
-> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> MessageClass
MCDiagnostic Severity
sev ResolvedDiagnosticReason
reason (a -> Maybe DiagnosticCode
forall a. Diagnostic a => a -> Maybe DiagnosticCode
diagnosticCode a
dia)) SrcSpan
s (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
                  (SDocContext -> SDocContext) -> SDoc -> SDoc
updSDocContext (\SDocContext
_ -> SDocContext
ctx) (a -> SDoc
Diagnostic a => a -> SDoc
messageWithHints a
dia))
              | msg :: MsgEnvelope a
msg@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,
                                  errMsgReason :: forall e. MsgEnvelope e -> ResolvedDiagnosticReason
errMsgReason     = ResolvedDiagnosticReason
reason,
                                  errMsgContext :: forall e. MsgEnvelope e -> NamePprCtx
errMsgContext    = NamePprCtx
name_ppr_ctx }
                  <- Maybe DiagOpts -> Bag (MsgEnvelope a) -> [MsgEnvelope a]
forall e. Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
sortMsgBag (DiagOpts -> Maybe DiagOpts
forall a. a -> Maybe a
Just DiagOpts
opts) (Messages a -> Bag (MsgEnvelope a)
forall e. Messages e -> Bag (MsgEnvelope e)
getMessages Messages a
msgs) ]
  where
    messageWithHints :: Diagnostic a => a -> SDoc
    messageWithHints :: Diagnostic a => a -> SDoc
messageWithHints a
e =
      let main_msg :: SDoc
main_msg = DecoratedSDoc -> SDoc
formatBulleted (DecoratedSDoc -> SDoc) -> DecoratedSDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ DiagnosticOpts a -> a -> DecoratedSDoc
forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticMessage DiagnosticOpts a
msg_opts a
e
          in case a -> [GhcHint]
forall a. Diagnostic a => a -> [GhcHint]
diagnosticHints a
e of
               []  -> SDoc
main_msg
               [GhcHint
h] -> SDoc
main_msg SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Suggested fix:") Int
2 (GhcHint -> SDoc
forall a. Outputable a => a -> SDoc
ppr GhcHint
h)
               [GhcHint]
hs  -> SDoc
main_msg SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Suggested fixes:") Int
2
                                       (DecoratedSDoc -> SDoc
formatBulleted  (DecoratedSDoc -> SDoc) -> DecoratedSDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> DecoratedSDoc
mkDecorated ([SDoc] -> DecoratedSDoc)
-> ([GhcHint] -> [SDoc]) -> [GhcHint] -> DecoratedSDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GhcHint -> SDoc) -> [GhcHint] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GhcHint -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([GhcHint] -> DecoratedSDoc) -> [GhcHint] -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ [GhcHint]
hs)
    log_diags_as_json :: Bool
log_diags_as_json = LogFlags -> Bool
log_diagnostics_as_json (Logger -> LogFlags
logFlags Logger
logger)

-- | Given a bag of diagnostics, turn them into an exception if
-- any has 'SevError', or print them out otherwise.
printOrThrowDiagnostics :: Logger -> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics :: Logger
-> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics Logger
logger GhcMessageOpts
print_config DiagOpts
opts Messages GhcMessage
msgs
  | Messages GhcMessage -> Bool
forall e. Messages e -> Bool
errorsOrFatalWarningsFound Messages GhcMessage
msgs
  = Messages GhcMessage -> IO ()
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors Messages GhcMessage
msgs
  | Bool
otherwise
  = Logger
-> DiagnosticOpts GhcMessage
-> DiagOpts
-> Messages GhcMessage
-> IO ()
forall a.
Diagnostic a =>
Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
printMessages Logger
logger DiagnosticOpts GhcMessage
GhcMessageOpts
print_config 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 = (PsMessage -> DriverMessage)
-> MsgEnvelope PsMessage -> MsgEnvelope DriverMessage
forall a b. (a -> b) -> MsgEnvelope a -> MsgEnvelope b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsMessage -> DriverMessage
DriverPsHeaderMessage