{-# 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)
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
mkDriverPsHeaderMessage :: MsgEnvelope PsMessage -> MsgEnvelope DriverMessage
= (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