Simon Hengel pushed to branch wip/sol/add-rendered-to-json-diagnostics at Glasgow Haskell Compiler / GHC

Commits:

9 changed files:

Changes:

  • compiler/GHC/Driver/Errors.hs
    ... ... @@ -7,27 +7,63 @@ module GHC.Driver.Errors (
    7 7
    8 8 
     import GHC.Driver.Errors.Types
    9 9 
     import GHC.Prelude
    10 
    +import GHC.Types.SrcLoc (SrcSpan)
    10 11 
     import GHC.Types.SourceError
    11 12 
     import GHC.Types.Error
    13 
    +import GHC.Utils.Json
    12 14 
     import GHC.Utils.Error
    13 
    -import GHC.Utils.Outputable (hang, ppr, ($$),  text, mkErrStyle, sdocStyle, updSDocContext )
    15 
    +import GHC.Utils.Outputable
    14 16 
     import GHC.Utils.Logger
    15 17
    16 18 
     printMessages :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
    17 
    -printMessages logger msg_opts opts msgs
    18 
    -  = sequence_ [ let style = mkErrStyle name_ppr_ctx
    19 
    -                    ctx   = (diag_ppr_ctx opts) { sdocStyle = style }
    20 
    -                in (if log_diags_as_json
    21 
    -                    then logJsonMsg logger (MCDiagnostic sev reason (diagnosticCode dia)) msg
    22 
    -                    else logMsg logger (MCDiagnostic sev reason (diagnosticCode dia)) s $
    23 
    -                  updSDocContext (\_ -> ctx) (messageWithHints dia))
    24 
    -              | msg@MsgEnvelope { errMsgSpan       = s,
    25 
    -                                  errMsgDiagnostic = dia,
    26 
    -                                  errMsgSeverity   = sev,
    27 
    -                                  errMsgReason     = reason,
    28 
    -                                  errMsgContext    = name_ppr_ctx }
    29 
    -                  <- sortMsgBag (Just opts) (getMessages msgs) ]
    19 
    +printMessages logger msg_opts opts = mapM_ printMessage . sortMessages
    30 20 
       where
    21 
    +    sortMessages :: Messages a -> [MsgEnvelope a]
    22 
    +    sortMessages = sortMsgBag (Just opts) . getMessages
    23 
    +
    24 
    +    printMessage :: MsgEnvelope a -> IO ()
    25 
    +    printMessage message
    26 
    +      | log_diags_as_json = do
    27 
    +          docWithHeader <- addCaret logflags messageClass location (addHeader doc)
    28 
    +          let
    29 
    +            rendered :: String
    30 
    +            rendered = renderWithContext (log_default_user_context logflags) docWithHeader
    31 
    +
    32 
    +            jsonMessage :: JsonDoc
    33 
    +            jsonMessage = case json message of
    34 
    +              JSObject xs -> JSObject (("rendered", JSString rendered) : xs)
    35 
    +              xs -> xs
    36 
    +          logJsonMsg logger messageClass jsonMessage
    37 
    +
    38 
    +      | otherwise = logMsg logger messageClass location doc
    39 
    +        where
    40 
    +          logflags :: LogFlags
    41 
    +          logflags = logFlags logger
    42 
    +
    43 
    +          addHeader :: SDoc -> SDoc
    44 
    +          addHeader = mkLocMessageWarningGroups (log_show_warn_groups logflags) messageClass location
    45 
    +
    46 
    +          doc :: SDoc
    47 
    +          doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic)
    48 
    +
    49 
    +          messageClass :: MessageClass
    50 
    +          messageClass = MCDiagnostic severity (errMsgReason message) (diagnosticCode diagnostic)
    51 
    +
    52 
    +          style :: PprStyle
    53 
    +          style = mkErrStyle (errMsgContext message)
    54 
    +
    55 
    +          location :: SrcSpan
    56 
    +          location = errMsgSpan message
    57 
    +
    58 
    +          ctx :: SDocContext
    59 
    +          ctx = (diag_ppr_ctx opts) { sdocStyle = style }
    60 
    +
    61 
    +          diagnostic :: a
    62 
    +          diagnostic = errMsgDiagnostic message
    63 
    +
    64 
    +          severity :: Severity
    65 
    +          severity = errMsgSeverity message
    66 
    +
    31 67 
         messageWithHints :: a -> SDoc
    32 68 
         messageWithHints e =
    33 69 
           let main_msg = formatBulleted $ diagnosticMessage msg_opts e
    ... ... @@ -36,6 +72,8 @@ printMessages logger msg_opts opts msgs
    36 72 
                    [h] -> main_msg $$ hang (text "Suggested fix:") 2 (ppr h)
    37 73 
                    hs  -> main_msg $$ hang (text "Suggested fixes:") 2
    38 74 
                                            (formatBulleted  $ mkDecorated . map ppr $ hs)
    75 
    +
    76 
    +    log_diags_as_json :: Bool
    39 77 
         log_diags_as_json = log_diagnostics_as_json (logFlags logger)
    40 78
    41 79 
     -- | Given a bag of diagnostics, turn them into an exception if

  • compiler/GHC/Types/Error.hs
    ... ... @@ -573,7 +573,7 @@ instance ToJson DiagnosticCode where
    573 573 
     {- Note [Diagnostic Message JSON Schema]
    574 574 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    575 575 
     The below instance of ToJson must conform to the JSON schema
    576 
    -specified in docs/users_guide/diagnostics-as-json-schema-1_1.json.
    576 
    +specified in docs/users_guide/diagnostics-as-json-schema-1_2.json.
    577 577 
     When the schema is altered, please bump the version.
    578 578 
     If the content is altered in a backwards compatible way,
    579 579 
     update the minor version (e.g. 1.3 ~> 1.4).

  • compiler/GHC/Utils/Logger.hs
    ... ... @@ -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
    ... ... @@ -421,24 +423,65 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg
    421 423 
           MCDiagnostic SevIgnore _ _   -> pure () -- suppress the message
    422 424 
           MCDiagnostic _sev _rea _code -> printDiagnostics
    423 425 
         where
    424 
    -      printOut   = defaultLogActionHPrintDoc  logflags False out
    425 
    -      printErrs  = defaultLogActionHPrintDoc  logflags False err
    426 
    +      printOut :: SDoc -> IO ()
    427 
    +      printOut = defaultLogActionHPrintDoc logflags False out
    428 
    +
    429 
    +      printErrs :: SDoc -> IO ()
    430 
    +      printErrs = defaultLogActionHPrintDoc logflags False err
    431 
    +
    432 
    +      putStrSDoc :: SDoc -> IO ()
    426 433 
           putStrSDoc = defaultLogActionHPutStrDoc logflags False out
    434 
    +
    427 435 
           -- Pretty print the warning flag, if any (#10752)
    436 
    +      message :: SDoc
    428 437 
           message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg
    429 438
    430 
    -      printDiagnostics = do
    431 
    -        caretDiagnostic <-
    432 
    -            if log_show_caret logflags
    433 
    -            then getCaretDiagnostic msg_class srcSpan
    434 
    -            else pure empty
    435 
    -        printErrs $ getPprStyle $ \style ->
    436 
    -          withPprStyle (setStyleColoured True style)
    437 
    -            (message $+$ caretDiagnostic $+$ blankLine)
    438 
    -        -- careful (#2302): printErrs prints in UTF-8,
    439 
    -        -- whereas converting to string first and using
    440 
    -        -- hPutStr would just emit the low 8 bits of
    441 
    -        -- each unicode char.
    439 
    +      printDiagnostics :: IO ()
    440 
    +      printDiagnostics = addCaret logflags msg_class srcSpan message >>= printErrs
    441 
    +
    442 
    +-- This function is used by `defaultLogActionWithHandles` for non-JSON output,
    443 
    +-- and also by `GHC.Driver.Errors.printMessages` to produce the `rendered`
    444 
    +-- message on `-fdiagnostics-as-json`.
    445 
    +--
    446 
    +-- We would want to eventually consolidate this.  However, this is currently
    447 
    +-- not feasible for the following reasons:
    448 
    +--
    449 
    +-- 1. Some parts of the compiler sidestep `printMessages`, for that reason we
    450 
    +--    can not decorate (`addCaret` + `defaultLogActionHPrintDoc`) the
    451 
    +--    message in `printMessages`.
    452 
    +--
    453 
    +-- 2. GHC uses two different code paths for JSON and non-JSON diagnostics.  For
    454 
    +--    that reason we can decorate the message in `defaultLogActionWithHandles`.
    455 
    +--
    456 
    +--    See also Note [JSON Error Messages]:
    457 
    +--
    458 
    +--      `jsonLogAction` should be removed along with -ddump-json
    459 
    +--
    460 
    +-- Also note that (1) is the reason why some parts of the compiler produce
    461 
    +-- diagnostics that don't respect `-fdiagnostics-as-json`.
    462 
    +--
    463 
    +-- The plan as I see it is as follows:
    464 
    +--
    465 
    +--  1. Refactor all places in the compiler that report diagnostics to go
    466 
    +--     through `GHC.Driver.Errors.printMessages`.
    467 
    +--
    468 
    +--     (It's easy to find all those places by looking for who creates
    469 
    +--     MCDiagnostic, either directly or via `mkMCDiagnostic` or
    470 
    +--     `errorDiagnostic`.)
    471 
    +--
    472 
    +--  2. Get rid of `-ddump-json`, `jsonLogAction` and consolidate message
    473 
    +--     decoration at one place (either `printMessages` or
    474 
    +--     `defaultLogActionWithHandles`)
    475 
    +--
    476 
    +addCaret :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc
    477 
    +addCaret logflags msg_class srcSpan message = do
    478 
    +  caretDiagnostic <-
    479 
    +      if log_show_caret logflags
    480 
    +      then getCaretDiagnostic msg_class srcSpan
    481 
    +      else pure empty
    482 
    +  return $ getPprStyle $ \style ->
    483 
    +    withPprStyle (setStyleColoured True style)
    484 
    +      (message $+$ caretDiagnostic $+$ blankLine)
    442 485
    443 486 
     -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.
    444 487 
     defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO ()
    ... ... @@ -474,6 +517,8 @@ defaultLogActionHPutStrDoc logflags asciiSpace h d
    474 517 
     -- -ddump-json is being deprecated, `jsonLogAction` has been added in, but
    475 518 
     -- it should be removed along with -ddump-json. Similarly, the guard in
    476 519 
     -- `defaultLogAction` should be removed. This cleanup is tracked in #24113.
    520 
    +--
    521 
    +--
    477 522
    478 523 
     -- | Default action for 'dumpAction' hook
    479 524 
     defaultDumpAction :: DumpCache -> LogAction -> DumpAction
    ... ... @@ -603,8 +648,8 @@ defaultTraceAction logflags title doc x =
    603 648 
     logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
    604 649 
     logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg
    605 650
    606 
    -logJsonMsg :: ToJson a => Logger -> MessageClass -> a -> IO ()
    607 
    -logJsonMsg logger mc d = putJsonLogMsg logger (logFlags logger) mc  (json d)
    651 
    +logJsonMsg :: Logger -> MessageClass -> JsonDoc -> IO ()
    652 
    +logJsonMsg logger mc = putJsonLogMsg logger (logFlags logger) mc
    608 653
    609 654 
     -- | Dump something
    610 655 
     logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()

  • compiler/GHC/Utils/Ppr.hs
    ... ... @@ -1114,6 +1114,7 @@ printDoc_ mode pprCols hdl doc
    1114 1114 
       = do { fullRender mode pprCols 1.5 put done doc ;
    1115 1115 
              hFlush hdl }
    1116 1116 
       where
    1117 
    +    put :: TextDetails -> IO a -> IO a
    1117 1118 
         put (Chr c)    next = hPutChar hdl c >> next
    1118 1119 
         put (Str s)    next = hPutStr  hdl s >> next
    1119 1120 
         put (PStr s)   next = hPutStr  hdl (unpackFS s) >> next
    ... ... @@ -1126,6 +1127,8 @@ printDoc_ mode pprCols hdl doc
    1126 1127 
           = putSpaces n >> next
    1127 1128 
           | otherwise
    1128 1129 
           = hPutStr hdl (replicate n c) >> next
    1130 
    +
    1131 
    +    putSpaces :: Int -> IO ()
    1129 1132 
         putSpaces n
    1130 1133 
           -- If we use ascii spaces we are allowed to use hPutBuf
    1131 1134 
           -- See Note [putSpaces optimizations]
    ... ... @@ -1138,11 +1141,12 @@ printDoc_ mode pprCols hdl doc
    1138 1141
    1139 1142 
           | otherwise = hPutStr hdl (replicate n ' ')
    1140 1143
    1144 
    +    done :: IO ()
    1141 1145 
         done = return () -- hPutChar hdl '\n'
    1146 
    +
    1142 1147 
         -- 100 spaces, so we avoid the allocation of replicate n ' '
    1143 1148 
         spaces' = "                                                                                                    "#
    1144 1149
    1145 
    -
    1146 1150 
       -- some versions of hPutBuf will barf if the length is zero
    1147 1151 
     hPutPtrString :: Handle -> PtrString -> IO ()
    1148 1152 
     hPutPtrString _handle (PtrString _ 0) = return ()

  • docs/users_guide/9.14.1-notes.rst
    ... ... @@ -143,6 +143,11 @@ Compiler
    143 143 
       were accessed using the generated record selector functions, marking the fields
    144 144 
       as covered in coverage reports (:ghc-ticket:`17834`).
    145 145
    146 
    +- JSON diagnostics produced with (:ghc-flag:`-fdiagnostics-as-json`) now
    147 
    +  include the `rendered` diagnostics message, in the exact same format as what
    148 
    +  GHC would have produced without -fdiagnostics-as-json (including ANSI escape
    149 
    +  sequences).
    150 
    +
    146 151 
     GHCi
    147 152 
     ~~~~
    148 153

  • docs/users_guide/diagnostics-as-json-schema-1_2.json
    1 
    +{
    2 
    +  "$schema": "https://json-schema.org/draft/2020-12/schema",
    3 
    +  "title": "JSON Diagnostic Schema",
    4 
    +  "description": "A Schema for specifying GHC diagnostics output as JSON",
    5 
    +  "type": "object",
    6 
    +  "properties": {
    7 
    +    "version": {
    8 
    +      "description": "The current JSON schema version this object conforms to",
    9 
    +      "type": "string"
    10 
    +    },
    11 
    +    "ghcVersion": {
    12 
    +      "description": "The GHC version",
    13 
    +      "type": "string"
    14 
    +    },
    15 
    +    "span": {
    16 
    +      "oneOf": [
    17 
    +        { "$ref": "#/$defs/span" },
    18 
    +        { "type": "null" }
    19 
    +      ]
    20 
    +    },
    21 
    +    "severity": {
    22 
    +      "description": "The diagnostic severity",
    23 
    +      "type": "string",
    24 
    +      "enum": [
    25 
    +        "Warning",
    26 
    +        "Error"
    27 
    +      ]
    28 
    +    },
    29 
    +    "code": {
    30 
    +      "description": "The diagnostic code (if it exists)",
    31 
    +      "type": [
    32 
    +        "integer",
    33 
    +        "null"
    34 
    +      ]
    35 
    +    },
    36 
    +    "rendered": {
    37 
    +      "description": "The rendered diagnostics message, in the exact same format as what GHC would have produced without -fdiagnostics-as-json (including ANSI escape sequences)",
    38 
    +      "type": "string"
    39 
    +    },
    40 
    +    "message": {
    41 
    +      "description": "The string output of the diagnostic message by GHC",
    42 
    +      "type": "array",
    43 
    +      "items": {
    44 
    +        "type": "string"
    45 
    +      }
    46 
    +    },
    47 
    +    "hints": {
    48 
    +      "description": "The suggested fixes",
    49 
    +      "type": "array",
    50 
    +      "items": {
    51 
    +        "type": "string"
    52 
    +      }
    53 
    +    },
    54 
    +    "reason" : {
    55 
    +      "description": "The GHC flag that was responsible for the emission of the diagnostic message",
    56 
    +      "oneOf": [
    57 
    +        {
    58 
    +          "type": "object",
    59 
    +          "description": "The diagnostic message was controlled by one or more GHC flags",
    60 
    +          "properties": {
    61 
    +            "flags": {
    62 
    +              "type": "array",
    63 
    +              "items": {
    64 
    +                "description": "The name of a GHC flag controlling the diagnostic message",
    65 
    +                "type": "string"
    66 
    +              },
    67 
    +              "minItems": 1
    68 
    +            }
    69 
    +          },
    70 
    +          "required": ["flags"]
    71 
    +        },
    72 
    +        {
    73 
    +          "type": "object",
    74 
    +          "description": "The diagnostic message was controlled by a GHC diagnostic message category",
    75 
    +          "properties": {
    76 
    +            "category": {
    77 
    +              "description": "The name of the GHC diagnostic message category controlling the diagnostic message",
    78 
    +              "type": "string"
    79 
    +            }
    80 
    +          },
    81 
    +          "required": ["category"]
    82 
    +        }
    83 
    +      ]
    84 
    +    }
    85 
    +  },
    86 
    +
    87 
    +  "$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.",
    88 
    +  "required": [
    89 
    +    "version",
    90 
    +    "ghcVersion",
    91 
    +    "span",
    92 
    +    "severity",
    93 
    +    "code",
    94 
    +    "message",
    95 
    +    "hints"
    96 
    +  ],
    97 
    +
    98 
    +  "additionalProperties": false,
    99 
    +  "$defs": {
    100 
    +    "span": {
    101 
    +      "description": "The span of the diagnostic",
    102 
    +      "type": "object",
    103 
    +      "properties": {
    104 
    +        "file": {
    105 
    +          "description": "The file in which the diagnostic occurs",
    106 
    +          "type": "string"
    107 
    +        },
    108 
    +        "start": {
    109 
    +          "description": "The start location of the diagnostic",
    110 
    +          "$ref": "#/$defs/location"
    111 
    +        },
    112 
    +        "end": {
    113 
    +          "description": "The end location of the diagnostic",
    114 
    +          "$ref": "#/$defs/location"
    115 
    +        }
    116 
    +      },
    117 
    +      "required": [
    118 
    +        "file",
    119 
    +        "start",
    120 
    +        "end"
    121 
    +      ],
    122 
    +      "additionalProperties": false
    123 
    +    },
    124 
    +    "location": {
    125 
    +      "description": "A location in a text file",
    126 
    +      "type": "object",
    127 
    +      "properties": {
    128 
    +        "line": {
    129 
    +          "description": "The line number",
    130 
    +          "type": "integer"
    131 
    +        },
    132 
    +        "column": {
    133 
    +          "description": "The column number",
    134 
    +          "type": "integer"
    135 
    +        }
    136 
    +      },
    137 
    +      "required": [
    138 
    +        "line",
    139 
    +        "column"
    140 
    +      ],
    141 
    +      "additionalProperties": false
    142 
    +    }
    143 
    +  }
    144 
    +}

  • docs/users_guide/using.rst
    ... ... @@ -1428,7 +1428,7 @@ messages and in GHCi:
    1428 1428 
         a new line.
    1429 1429
    1430 1430 
         The structure of the output is described by a `JSON Schema <https://json-schema.org/>`_.
    1431 
    -    The schema can be downloaded :download:`here <diagnostics-as-json-schema-1_1.json>`.
    1431 
    +    The schema can be downloaded :download:`here <diagnostics-as-json-schema-1_2.json>`.
    1432 1432
    1433 1433 
     .. ghc-flag:: -fdiagnostics-color=⟨always|auto|never⟩
    1434 1434 
         :shortdesc: Use colors in error messages

  • testsuite/tests/driver/json.stderr
    1 
    -{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json.hs","start":{"line":9,"column":11},"end":{"line":9,"column":21}},"severity":"Error","code":48010,"message":["Empty list of alternatives in case expression"],"hints":["Perhaps you intended to use the \u2018EmptyCase\u2019 extension"]}
    1 
    +{"rendered":"json.hs:9:11: error: [GHC-48010]\n    Empty list of alternatives in case expression\n    Suggested fix:\n      Perhaps you intended to use the \u2018EmptyCase\u2019 extension\n","version":"1.1","ghcVersion":"ghc-9.13.20250627","span":{"file":"json.hs","start":{"line":9,"column":11},"end":{"line":9,"column":21}},"severity":"Error","code":48010,"message":["Empty list of alternatives in case expression"],"hints":["Perhaps you intended to use the \u2018EmptyCase\u2019 extension"]}

  • testsuite/tests/driver/json_warn.stderr
    1 
    -{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"message":["Defined but not used: \u2018x\u2019"],"hints":[],"reason":{"flags":["unused-matches"]}}
    2 
    -{"version":"1.1","ghcVersion":"ghc-9.13.20250529","span":{"file":"json_warn.hs","start":{"line":7,"column":5},"end":{"line":7,"column":9}},"severity":"Warning","code":63394,"message":["In the use of \u2018head\u2019\n(imported from Prelude, but defined in GHC.Internal.List):\n\"This is a partial function, it throws an error on empty lists. Use pattern matching, 'Data.List.uncons' or 'Data.Maybe.listToMaybe' instead. Consider refactoring to use \"Data.List.NonEmpty\".\""],"hints":[],"reason":{"category":"x-partial"}}
    1 
    +{"rendered":"json_warn.hs:4:3: warning: [GHC-40910] [-Wunused-matches (in -Wextra)]\n    Defined but not used: \u2018x\u2019\n","version":"1.1","ghcVersion":"ghc-9.13.20250627","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"message":["Defined but not used: \u2018x\u2019"],"hints":[],"reason":{"flags":["unused-matches"]}}
    2 
    +{"rendered":"json_warn.hs:7:5: warning: [GHC-63394] [-Wx-partial (in -Wextended-warnings)]\n    In the use of \u2018head\u2019\n    (imported from Prelude, but defined in GHC.Internal.List):\n    \"This is a partial function, it throws an error on empty lists. Use pattern matching, 'Data.List.uncons' or 'Data.Maybe.listToMaybe' instead. Consider refactoring to use \"Data.List.NonEmpty\".\"\n","version":"1.1","ghcVersion":"ghc-9.13.20250627","span":{"file":"json_warn.hs","start":{"line":7,"column":5},"end":{"line":7,"column":9}},"severity":"Warning","code":63394,"message":["In the use of \u2018head\u2019\n(imported from Prelude, but defined in GHC.Internal.List):\n\"This is a partial function, it throws an error on empty lists. Use pattern matching, 'Data.List.uncons' or 'Data.Maybe.listToMaybe' instead. Consider refactoring to use \"Data.List.NonEmpty\".\""],"hints":[],"reason":{"category":"x-partial"}}

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help