Simon Hengel pushed to branch wip/sol/add-rendered-to-json-diagnostics at Glasgow Haskell Compiler / GHC
Commits:
-
3ce82ba0
by Simon Hengel at 2025-07-08T03:45:48+07:00
2 changed files:
Changes:
| ... | ... | @@ -11,8 +11,9 @@ import GHC.Driver.Errors.Types |
| 11 | 11 | import GHC.Prelude
|
| 12 | 12 | import GHC.Types.SourceError
|
| 13 | 13 | import GHC.Types.Error
|
| 14 | +import GHC.Utils.Json
|
|
| 14 | 15 | import GHC.Utils.Error
|
| 15 | -import GHC.Utils.Outputable (SDocContext, PprStyle, hang, ppr, ($$), text, mkErrStyle, sdocStyle, updSDocContext)
|
|
| 16 | +import GHC.Utils.Outputable
|
|
| 16 | 17 | import GHC.Utils.Logger
|
| 17 | 18 | |
| 18 | 19 | printMessages :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
|
| ... | ... | @@ -23,9 +24,26 @@ printMessages logger msg_opts opts = mapM_ printMessage . sortMessages |
| 23 | 24 | |
| 24 | 25 | printMessage :: MsgEnvelope a -> IO ()
|
| 25 | 26 | printMessage message
|
| 26 | - | log_diags_as_json = logJsonMsg logger messageClass message
|
|
| 27 | + | log_diags_as_json = do
|
|
| 28 | + docWithHeader <- addCaret logflags messageClass location (addHeader doc)
|
|
| 29 | + let
|
|
| 30 | + rendered :: String
|
|
| 31 | + rendered = renderWithContext (log_default_user_context logflags) docWithHeader
|
|
| 32 | + |
|
| 33 | + jsonMessage :: JsonDoc
|
|
| 34 | + jsonMessage = case json message of
|
|
| 35 | + JSObject xs -> JSObject (("rendered", JSString rendered) : xs)
|
|
| 36 | + xs -> xs
|
|
| 37 | + logJsonMsg logger messageClass jsonMessage
|
|
| 38 | + |
|
| 27 | 39 | | otherwise = logMsg logger messageClass location doc
|
| 28 | 40 | where
|
| 41 | + logflags :: LogFlags
|
|
| 42 | + logflags = logFlags logger
|
|
| 43 | + |
|
| 44 | + addHeader :: SDoc -> SDoc
|
|
| 45 | + addHeader = mkLocMessageWarningGroups (log_show_warn_groups logflags) messageClass location
|
|
| 46 | + |
|
| 29 | 47 | doc :: SDoc
|
| 30 | 48 | doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic)
|
| 31 | 49 |
| ... | ... | @@ -21,6 +21,8 @@ module GHC.Utils.Logger |
| 21 | 21 | , HasLogger (..)
|
| 22 | 22 | , ContainsLogger (..)
|
| 23 | 23 | |
| 24 | + , addCaret
|
|
| 25 | + |
|
| 24 | 26 | -- * Logger setup
|
| 25 | 27 | , initLogger
|
| 26 | 28 | , LogAction
|
| ... | ... | @@ -435,18 +437,17 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg |
| 435 | 437 | message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg
|
| 436 | 438 | |
| 437 | 439 | printDiagnostics :: IO ()
|
| 438 | - printDiagnostics = do
|
|
| 439 | - caretDiagnostic <-
|
|
| 440 | - if log_show_caret logflags
|
|
| 441 | - then getCaretDiagnostic msg_class srcSpan
|
|
| 442 | - else pure empty
|
|
| 443 | - printErrs $ getPprStyle $ \style ->
|
|
| 444 | - withPprStyle (setStyleColoured True style)
|
|
| 445 | - (message $+$ caretDiagnostic $+$ blankLine)
|
|
| 446 | - -- careful (#2302): printErrs prints in UTF-8,
|
|
| 447 | - -- whereas converting to string first and using
|
|
| 448 | - -- hPutStr would just emit the low 8 bits of
|
|
| 449 | - -- each unicode char.
|
|
| 440 | + printDiagnostics = addCaret logflags msg_class srcSpan message >>= printErrs
|
|
| 441 | + |
|
| 442 | +addCaret :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc
|
|
| 443 | +addCaret logflags msg_class srcSpan message = do
|
|
| 444 | + caretDiagnostic <-
|
|
| 445 | + if log_show_caret logflags
|
|
| 446 | + then getCaretDiagnostic msg_class srcSpan
|
|
| 447 | + else pure empty
|
|
| 448 | + return $ getPprStyle $ \style ->
|
|
| 449 | + withPprStyle (setStyleColoured True style)
|
|
| 450 | + (message $+$ caretDiagnostic $+$ blankLine)
|
|
| 450 | 451 | |
| 451 | 452 | -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.
|
| 452 | 453 | defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO ()
|
| ... | ... | @@ -611,8 +612,8 @@ defaultTraceAction logflags title doc x = |
| 611 | 612 | logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
|
| 612 | 613 | logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg
|
| 613 | 614 | |
| 614 | -logJsonMsg :: ToJson a => Logger -> MessageClass -> a -> IO ()
|
|
| 615 | -logJsonMsg logger mc d = putJsonLogMsg logger (logFlags logger) mc (json d)
|
|
| 615 | +logJsonMsg :: Logger -> MessageClass -> JsonDoc -> IO ()
|
|
| 616 | +logJsonMsg logger mc = putJsonLogMsg logger (logFlags logger) mc
|
|
| 616 | 617 | |
| 617 | 618 | -- | Dump something
|
| 618 | 619 | logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
|