Simon Hengel pushed to branch wip/sol/add-rendered-to-json-diagnostics at Glasgow Haskell Compiler / GHC
Commits:
ddd19d42 by Simon Hengel at 2025-07-08T05:30:17+07:00
Refactoring
- - - - -
33746bc6 by Simon Hengel at 2025-07-08T05:30:31+07:00
Include the rendered message in -fdiagnostics-as-json output
This implements #26173.
- - - - -
9 changed files:
- compiler/GHC/Driver/Errors.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Utils/Logger.hs
- compiler/GHC/Utils/Ppr.hs
- docs/users_guide/9.14.1-notes.rst
- + docs/users_guide/diagnostics-as-json-schema-1_2.json
- docs/users_guide/using.rst
- testsuite/tests/driver/json.stderr
- testsuite/tests/driver/json_warn.stderr
Changes:
=====================================
compiler/GHC/Driver/Errors.hs
=====================================
@@ -7,27 +7,63 @@ module GHC.Driver.Errors (
import GHC.Driver.Errors.Types
import GHC.Prelude
+import GHC.Types.SrcLoc (SrcSpan)
import GHC.Types.SourceError
import GHC.Types.Error
+import GHC.Utils.Json
import GHC.Utils.Error
-import GHC.Utils.Outputable (hang, ppr, ($$), text, mkErrStyle, sdocStyle, updSDocContext )
+import GHC.Utils.Outputable
import GHC.Utils.Logger
printMessages :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
-printMessages logger msg_opts opts msgs
- = sequence_ [ let style = mkErrStyle name_ppr_ctx
- ctx = (diag_ppr_ctx opts) { sdocStyle = style }
- in (if log_diags_as_json
- then logJsonMsg logger (MCDiagnostic sev reason (diagnosticCode dia)) msg
- else logMsg logger (MCDiagnostic sev reason (diagnosticCode dia)) s $
- updSDocContext (\_ -> ctx) (messageWithHints dia))
- | msg@MsgEnvelope { errMsgSpan = s,
- errMsgDiagnostic = dia,
- errMsgSeverity = sev,
- errMsgReason = reason,
- errMsgContext = name_ppr_ctx }
- <- sortMsgBag (Just opts) (getMessages msgs) ]
+printMessages logger msg_opts opts = mapM_ printMessage . sortMessages
where
+ sortMessages :: Messages a -> [MsgEnvelope a]
+ sortMessages = sortMsgBag (Just opts) . getMessages
+
+ printMessage :: MsgEnvelope a -> IO ()
+ printMessage message
+ | log_diags_as_json = do
+ docWithHeader <- addCaret logflags messageClass location (addHeader doc)
+ let
+ rendered :: String
+ rendered = renderWithContext (log_default_user_context logflags) docWithHeader
+
+ jsonMessage :: JsonDoc
+ jsonMessage = case json message of
+ JSObject xs -> JSObject (("rendered", JSString rendered) : xs)
+ xs -> xs
+ logJsonMsg logger messageClass jsonMessage
+
+ | otherwise = logMsg logger messageClass location doc
+ where
+ logflags :: LogFlags
+ logflags = logFlags logger
+
+ addHeader :: SDoc -> SDoc
+ addHeader = mkLocMessageWarningGroups (log_show_warn_groups logflags) messageClass location
+
+ doc :: SDoc
+ doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic)
+
+ messageClass :: MessageClass
+ messageClass = MCDiagnostic severity (errMsgReason message) (diagnosticCode diagnostic)
+
+ style :: PprStyle
+ style = mkErrStyle (errMsgContext message)
+
+ location :: SrcSpan
+ location = errMsgSpan message
+
+ ctx :: SDocContext
+ ctx = (diag_ppr_ctx opts) { sdocStyle = style }
+
+ diagnostic :: a
+ diagnostic = errMsgDiagnostic message
+
+ severity :: Severity
+ severity = errMsgSeverity message
+
messageWithHints :: a -> SDoc
messageWithHints e =
let main_msg = formatBulleted $ diagnosticMessage msg_opts e
@@ -36,6 +72,8 @@ printMessages logger msg_opts opts msgs
[h] -> main_msg $$ hang (text "Suggested fix:") 2 (ppr h)
hs -> main_msg $$ hang (text "Suggested fixes:") 2
(formatBulleted $ mkDecorated . map ppr $ hs)
+
+ log_diags_as_json :: Bool
log_diags_as_json = log_diagnostics_as_json (logFlags logger)
-- | Given a bag of diagnostics, turn them into an exception if
=====================================
compiler/GHC/Types/Error.hs
=====================================
@@ -573,7 +573,7 @@ instance ToJson DiagnosticCode where
{- Note [Diagnostic Message JSON Schema]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The below instance of ToJson must conform to the JSON schema
-specified in docs/users_guide/diagnostics-as-json-schema-1_1.json.
+specified in docs/users_guide/diagnostics-as-json-schema-1_2.json.
When the schema is altered, please bump the version.
If the content is altered in a backwards compatible way,
update the minor version (e.g. 1.3 ~> 1.4).
=====================================
compiler/GHC/Utils/Logger.hs
=====================================
@@ -21,6 +21,8 @@ module GHC.Utils.Logger
, HasLogger (..)
, ContainsLogger (..)
+ , addCaret
+
-- * Logger setup
, initLogger
, LogAction
@@ -421,24 +423,65 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg
MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message
MCDiagnostic _sev _rea _code -> printDiagnostics
where
- printOut = defaultLogActionHPrintDoc logflags False out
- printErrs = defaultLogActionHPrintDoc logflags False err
+ printOut :: SDoc -> IO ()
+ printOut = defaultLogActionHPrintDoc logflags False out
+
+ printErrs :: SDoc -> IO ()
+ printErrs = defaultLogActionHPrintDoc logflags False err
+
+ putStrSDoc :: SDoc -> IO ()
putStrSDoc = defaultLogActionHPutStrDoc logflags False out
+
-- Pretty print the warning flag, if any (#10752)
+ message :: SDoc
message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg
- printDiagnostics = do
- caretDiagnostic <-
- if log_show_caret logflags
- then getCaretDiagnostic msg_class srcSpan
- else pure empty
- printErrs $ getPprStyle $ \style ->
- withPprStyle (setStyleColoured True style)
- (message $+$ caretDiagnostic $+$ blankLine)
- -- careful (#2302): printErrs prints in UTF-8,
- -- whereas converting to string first and using
- -- hPutStr would just emit the low 8 bits of
- -- each unicode char.
+ printDiagnostics :: IO ()
+ printDiagnostics = addCaret logflags msg_class srcSpan message >>= printErrs
+
+-- This function is used by `defaultLogActionWithHandles` for non-JSON output,
+-- and also by `GHC.Driver.Errors.printMessages` to produce the `rendered`
+-- message on `-fdiagnostics-as-json`.
+--
+-- We would want to eventually consolidate this. However, this is currently
+-- not feasible for the following reasons:
+--
+-- 1. Some parts of the compiler sidestep `printMessages`, for that reason we
+-- can not decorate (`addCaret` + `defaultLogActionHPrintDoc`) the
+-- message in `printMessages`.
+--
+-- 2. GHC uses two different code paths for JSON and non-JSON diagnostics. For
+-- that reason we can decorate the message in `defaultLogActionWithHandles`.
+--
+-- See also Note [JSON Error Messages]:
+--
+-- `jsonLogAction` should be removed along with -ddump-json
+--
+-- Also note that (1) is the reason why some parts of the compiler produce
+-- diagnostics that don't respect `-fdiagnostics-as-json`.
+--
+-- The plan as I see it is as follows:
+--
+-- 1. Refactor all places in the compiler that report diagnostics to go
+-- through `GHC.Driver.Errors.printMessages`.
+--
+-- (It's easy to find all those places by looking for who creates
+-- MCDiagnostic, either directly or via `mkMCDiagnostic` or
+-- `errorDiagnostic`.)
+--
+-- 2. Get rid of `-ddump-json`, `jsonLogAction` and consolidate message
+-- decoration at one place (either `printMessages` or
+-- `defaultLogActionWithHandles`)
+--
+addCaret :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc
+addCaret logflags msg_class srcSpan message = do
+ caretDiagnostic <-
+ if log_show_caret logflags
+ then getCaretDiagnostic msg_class srcSpan
+ else pure empty
+ return $ getPprStyle $ \style ->
+ withPprStyle (setStyleColoured True style)
+ (message $+$ caretDiagnostic $+$ blankLine)
-- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.
defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO ()
@@ -474,6 +517,8 @@ defaultLogActionHPutStrDoc logflags asciiSpace h d
-- -ddump-json is being deprecated, `jsonLogAction` has been added in, but
-- it should be removed along with -ddump-json. Similarly, the guard in
-- `defaultLogAction` should be removed. This cleanup is tracked in #24113.
+--
+--
-- | Default action for 'dumpAction' hook
defaultDumpAction :: DumpCache -> LogAction -> DumpAction
@@ -603,8 +648,8 @@ defaultTraceAction logflags title doc x =
logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg
-logJsonMsg :: ToJson a => Logger -> MessageClass -> a -> IO ()
-logJsonMsg logger mc d = putJsonLogMsg logger (logFlags logger) mc (json d)
+logJsonMsg :: Logger -> MessageClass -> JsonDoc -> IO ()
+logJsonMsg logger mc = putJsonLogMsg logger (logFlags logger) mc
-- | Dump something
logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
=====================================
compiler/GHC/Utils/Ppr.hs
=====================================
@@ -1114,6 +1114,7 @@ printDoc_ mode pprCols hdl doc
= do { fullRender mode pprCols 1.5 put done doc ;
hFlush hdl }
where
+ put :: TextDetails -> IO a -> IO a
put (Chr c) next = hPutChar hdl c >> next
put (Str s) next = hPutStr hdl s >> next
put (PStr s) next = hPutStr hdl (unpackFS s) >> next
@@ -1126,6 +1127,8 @@ printDoc_ mode pprCols hdl doc
= putSpaces n >> next
| otherwise
= hPutStr hdl (replicate n c) >> next
+
+ putSpaces :: Int -> IO ()
putSpaces n
-- If we use ascii spaces we are allowed to use hPutBuf
-- See Note [putSpaces optimizations]
@@ -1138,11 +1141,12 @@ printDoc_ mode pprCols hdl doc
| otherwise = hPutStr hdl (replicate n ' ')
+ done :: IO ()
done = return () -- hPutChar hdl '\n'
+
-- 100 spaces, so we avoid the allocation of replicate n ' '
spaces' = " "#
-
-- some versions of hPutBuf will barf if the length is zero
hPutPtrString :: Handle -> PtrString -> IO ()
hPutPtrString _handle (PtrString _ 0) = return ()
=====================================
docs/users_guide/9.14.1-notes.rst
=====================================
@@ -143,6 +143,11 @@ Compiler
were accessed using the generated record selector functions, marking the fields
as covered in coverage reports (:ghc-ticket:`17834`).
+- JSON diagnostics produced with (:ghc-flag:`-fdiagnostics-as-json`) now
+ include the `rendered` diagnostics message, in the exact same format as what
+ GHC would have produced without -fdiagnostics-as-json (including ANSI escape
+ sequences).
+
GHCi
~~~~
=====================================
docs/users_guide/diagnostics-as-json-schema-1_2.json
=====================================
@@ -0,0 +1,144 @@
+{
+ "$schema": "https://json-schema.org/draft/2020-12/schema",
+ "title": "JSON Diagnostic Schema",
+ "description": "A Schema for specifying GHC diagnostics output as JSON",
+ "type": "object",
+ "properties": {
+ "version": {
+ "description": "The current JSON schema version this object conforms to",
+ "type": "string"
+ },
+ "ghcVersion": {
+ "description": "The GHC version",
+ "type": "string"
+ },
+ "span": {
+ "oneOf": [
+ { "$ref": "#/$defs/span" },
+ { "type": "null" }
+ ]
+ },
+ "severity": {
+ "description": "The diagnostic severity",
+ "type": "string",
+ "enum": [
+ "Warning",
+ "Error"
+ ]
+ },
+ "code": {
+ "description": "The diagnostic code (if it exists)",
+ "type": [
+ "integer",
+ "null"
+ ]
+ },
+ "rendered": {
+ "description": "The rendered diagnostics message, in the exact same format as what GHC would have produced without -fdiagnostics-as-json (including ANSI escape sequences)",
+ "type": "string"
+ },
+ "message": {
+ "description": "The string output of the diagnostic message by GHC",
+ "type": "array",
+ "items": {
+ "type": "string"
+ }
+ },
+ "hints": {
+ "description": "The suggested fixes",
+ "type": "array",
+ "items": {
+ "type": "string"
+ }
+ },
+ "reason" : {
+ "description": "The GHC flag that was responsible for the emission of the diagnostic message",
+ "oneOf": [
+ {
+ "type": "object",
+ "description": "The diagnostic message was controlled by one or more GHC flags",
+ "properties": {
+ "flags": {
+ "type": "array",
+ "items": {
+ "description": "The name of a GHC flag controlling the diagnostic message",
+ "type": "string"
+ },
+ "minItems": 1
+ }
+ },
+ "required": ["flags"]
+ },
+ {
+ "type": "object",
+ "description": "The diagnostic message was controlled by a GHC diagnostic message category",
+ "properties": {
+ "category": {
+ "description": "The name of the GHC diagnostic message category controlling the diagnostic message",
+ "type": "string"
+ }
+ },
+ "required": ["category"]
+ }
+ ]
+ }
+ },
+
+ "$comment": "NOTE: \"rendered\" is not a required field so that the schema is backward compatible with version 1.1. If you bump the schema version to 2.0 the please also add \"rendered\" to the \"required\" fields.",
+ "required": [
+ "version",
+ "ghcVersion",
+ "span",
+ "severity",
+ "code",
+ "message",
+ "hints"
+ ],
+
+ "additionalProperties": false,
+ "$defs": {
+ "span": {
+ "description": "The span of the diagnostic",
+ "type": "object",
+ "properties": {
+ "file": {
+ "description": "The file in which the diagnostic occurs",
+ "type": "string"
+ },
+ "start": {
+ "description": "The start location of the diagnostic",
+ "$ref": "#/$defs/location"
+ },
+ "end": {
+ "description": "The end location of the diagnostic",
+ "$ref": "#/$defs/location"
+ }
+ },
+ "required": [
+ "file",
+ "start",
+ "end"
+ ],
+ "additionalProperties": false
+ },
+ "location": {
+ "description": "A location in a text file",
+ "type": "object",
+ "properties": {
+ "line": {
+ "description": "The line number",
+ "type": "integer"
+ },
+ "column": {
+ "description": "The column number",
+ "type": "integer"
+ }
+ },
+ "required": [
+ "line",
+ "column"
+ ],
+ "additionalProperties": false
+ }
+ }
+}
=====================================
docs/users_guide/using.rst
=====================================
@@ -1428,7 +1428,7 @@ messages and in GHCi:
a new line.
The structure of the output is described by a `JSON Schema https://json-schema.org/`_.
- The schema can be downloaded :download:`here
participants (1)
-
Simon Hengel (＠sol)