From dfd670a0fcd38e5c169fbc7980fa433a9eb371a0 Mon Sep 17 00:00:00 2001
From: Ben Bellick <benbellick@protonmail.com>
Date: Wed, 5 Jul 2023 22:55:11 -0400
Subject: [PATCH] Deprecate -ddump-json and introduce -fdiagnostics-as-json
Addresses #19278
This commit deprecates the underspecified -ddump-json flag and
introduces a newer, well-specified flag -fdiagnostics-as-json.
Also included is a JSON schema as part of the documentation.
The -ddump-json flag will be slated for removal shortly after this merge.
---
compiler/GHC/Driver/Config/Logger.hs | 1 +
compiler/GHC/Driver/Errors.hs | 17 +--
compiler/GHC/Driver/Flags.hs | 1 +
compiler/GHC/Driver/Monad.hs | 8 ++
compiler/GHC/Driver/Session.hs | 7 +-
compiler/GHC/Types/Error.hs | 51 ++++++++-
compiler/GHC/Types/SrcLoc.hs | 12 +-
compiler/GHC/Utils/Logger.hs | 70 +++++++++++-
docs/users_guide/debugging.rst | 7 +-
.../diagnostics-as-json-schema-1_0.json | 103 ++++++++++++++++++
docs/users_guide/using.rst | 13 +++
.../tests/count-deps/CountDepsAst.stdout | 1 +
testsuite/tests/driver/T16167.stdout | 1 +
testsuite/tests/driver/all.T | 10 +-
testsuite/tests/driver/json.hs | 7 +-
testsuite/tests/driver/json.stderr | 2 +-
testsuite/tests/driver/json2.stderr | 3 +-
testsuite/tests/driver/json_dump.hs | 6 +
testsuite/tests/driver/json_dump.stderr | 2 +
testsuite/tests/driver/json_warn.hs | 4 +
testsuite/tests/driver/json_warn.stderr | 1 +
21 files changed, 292 insertions(+), 35 deletions(-)
create mode 100644 docs/users_guide/diagnostics-as-json-schema-1_0.json
create mode 100644 testsuite/tests/driver/json_dump.hs
create mode 100644 testsuite/tests/driver/json_dump.stderr
create mode 100644 testsuite/tests/driver/json_warn.hs
create mode 100644 testsuite/tests/driver/json_warn.stderr
diff --git a/compiler/GHC/Driver/Config/Logger.hs b/compiler/GHC/Driver/Config/Logger.hs
index e5303826a5f0..fc823b4ff3e4 100644
--- a/compiler/GHC/Driver/Config/Logger.hs
+++ b/compiler/GHC/Driver/Config/Logger.hs
@@ -17,6 +17,7 @@ initLogFlags dflags = LogFlags
, log_default_dump_context = initSDocContext dflags defaultDumpStyle
, log_dump_flags = dumpFlags dflags
, log_show_caret = gopt Opt_DiagnosticsShowCaret dflags
+ , log_diagnostics_as_json = gopt Opt_DiagnosticsAsJSON dflags
, log_show_warn_groups = gopt Opt_ShowWarnGroups dflags
, log_enable_timestamps = not (gopt Opt_SuppressTimestamps dflags)
, log_dump_to_file = gopt Opt_DumpToFile dflags
diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs
index 0d4ce78945c9..db2d72b6e142 100644
--- a/compiler/GHC/Driver/Errors.hs
+++ b/compiler/GHC/Driver/Errors.hs
@@ -17,13 +17,15 @@ printMessages :: forall a . Diagnostic a => Logger -> DiagnosticOpts a -> DiagOp
printMessages logger msg_opts opts msgs
= sequence_ [ let style = mkErrStyle name_ppr_ctx
ctx = (diag_ppr_ctx opts) { sdocStyle = style }
- in logMsg logger (MCDiagnostic sev reason (diagnosticCode dia)) s $
- updSDocContext (\_ -> ctx) (messageWithHints dia)
- | MsgEnvelope { errMsgSpan = s,
- errMsgDiagnostic = dia,
- errMsgSeverity = sev,
- errMsgReason = reason,
- errMsgContext = name_ppr_ctx }
+ 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) ]
where
messageWithHints :: Diagnostic a => a -> SDoc
@@ -34,6 +36,7 @@ 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 = log_diagnostics_as_json (logFlags logger)
-- | Given a bag of diagnostics, turn them into an exception if
-- any has 'SevError', or print them out otherwise.
diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index 38078ce4a9c1..4fda2f1835b2 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -412,6 +412,7 @@ data GeneralFlag
| Opt_ErrorSpans -- Include full span info in error messages,
-- instead of just the start position.
| Opt_DeferDiagnostics
+ | Opt_DiagnosticsAsJSON -- ^ Dump diagnostics as JSON
| Opt_DiagnosticsShowCaret -- Show snippets of offending code
| Opt_PprCaseAsLet
| Opt_PprShowTicks
diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs
index f26df96ad057..c2eeaa7868d4 100644
--- a/compiler/GHC/Driver/Monad.hs
+++ b/compiler/GHC/Driver/Monad.hs
@@ -23,6 +23,8 @@ module GHC.Driver.Monad (
modifyLogger,
pushLogHookM,
popLogHookM,
+ pushJsonLogHookM,
+ popJsonLogHookM,
putLogMsgM,
putMsgM,
withTimingM,
@@ -121,6 +123,12 @@ pushLogHookM = modifyLogger . pushLogHook
popLogHookM :: GhcMonad m => m ()
popLogHookM = modifyLogger popLogHook
+pushJsonLogHookM :: GhcMonad m => (LogJsonAction -> LogJsonAction) -> m ()
+pushJsonLogHookM = modifyLogger . pushJsonLogHook
+
+popJsonLogHookM :: GhcMonad m => m ()
+popJsonLogHookM = modifyLogger popJsonLogHook
+
-- | Put a log message
putMsgM :: GhcMonad m => SDoc -> m ()
putMsgM doc = do
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index e2ea89c42bb9..93841ff1c337 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -1573,15 +1573,15 @@ dynamic_flags_deps = [
(NoArg (setGeneralFlag Opt_NoTypeableBinds))
, make_ord_flag defGhcFlag "ddump-debug"
(setDumpFlag Opt_D_dump_debug)
- , make_ord_flag defGhcFlag "ddump-json"
- (setDumpFlag Opt_D_dump_json )
+ , make_dep_flag defGhcFlag "ddump-json"
+ (setDumpFlag Opt_D_dump_json)
+ "Use `-fdiagnostics-as-json` instead"
, make_ord_flag defGhcFlag "dppr-debug"
(setDumpFlag Opt_D_ppr_debug)
, make_ord_flag defGhcFlag "ddebug-output"
(noArg (flip dopt_unset Opt_D_no_debug_output))
, make_ord_flag defGhcFlag "dno-debug-output"
(setDumpFlag Opt_D_no_debug_output)
-
, make_ord_flag defGhcFlag "ddump-faststrings"
(setDumpFlag Opt_D_dump_faststrings)
@@ -2354,6 +2354,7 @@ fFlagsDeps = [
flagSpec "defer-typed-holes" Opt_DeferTypedHoles,
flagSpec "defer-out-of-scope-variables" Opt_DeferOutOfScopeVariables,
flagSpec "diagnostics-show-caret" Opt_DiagnosticsShowCaret,
+ flagSpec "diagnostics-as-json" Opt_DiagnosticsAsJSON,
-- With-ways needs to be reversible hence why its made via flagSpec unlike
-- other debugging flags.
flagSpec "dump-with-ways" Opt_DumpWithWays,
diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs
index 2cdc2826ea79..ef94dd212520 100644
--- a/compiler/GHC/Types/Error.hs
+++ b/compiler/GHC/Types/Error.hs
@@ -103,15 +103,16 @@ import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)
import GHC.Utils.Json
import GHC.Utils.Panic
import GHC.Unit.Module.Warnings (WarningCategory)
-
import Data.Bifunctor
-import Data.Foldable ( fold )
+import Data.Foldable ( fold, toList )
import Data.List.NonEmpty ( NonEmpty (..) )
import qualified Data.List.NonEmpty as NE
import Data.List ( intercalate )
import Data.Typeable ( Typeable )
import Numeric.Natural ( Natural )
import Text.Printf ( printf )
+import GHC.Version (cProjectVersion)
+import GHC.Types.Hint.Ppr () -- Outputtable instance
{- Note [Messages]
~~~~~~~~~~~~~~~~~~
@@ -166,6 +167,9 @@ instance Diagnostic e => Outputable (Messages e) where
pprDiagnostic (errMsgDiagnostic envelope)
]
+instance Diagnostic e => ToJson (Messages e) where
+ json msgs = JSArray . toList $ json <$> getMessages msgs
+
{- Note [Discarding Messages]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -540,7 +544,9 @@ instance Outputable Severity where
SevError -> text "SevError"
instance ToJson Severity where
- json s = JSString (show s)
+ json SevIgnore = JSString "Ignore"
+ json SevWarning = JSString "Warning"
+ json SevError = JSString "Error"
instance ToJson MessageClass where
json MCOutput = JSString "MCOutput"
@@ -551,6 +557,45 @@ instance ToJson MessageClass where
json (MCDiagnostic sev reason code) =
JSString $ renderWithContext defaultSDocContext (ppr $ text "MCDiagnostic" <+> ppr sev <+> ppr reason <+> ppr code)
+instance ToJson DiagnosticCode where
+ json c = JSInt (fromIntegral (diagnosticCodeNumber c))
+
+{- 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_0.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).
+If the content is breaking, update the major version (e.g. 1.3 ~> 2.3).
+When updating the schema, replace the above file and name it appropriately with
+the version appended, and change the documentation of the -fdiagnostics-as-json
+flag to reflect the new schema.
+To learn more about JSON schemas, check out the below link:
+https://json-schema.org
+-}
+
+schemaVersion :: String
+schemaVersion = "1.0"
+-- See Note [Diagnostic Message JSON Schema] before editing!
+instance Diagnostic e => ToJson (MsgEnvelope e) where
+ json m = JSObject [
+ ("version", JSString schemaVersion),
+ ("ghcVersion", JSString $ "ghc-" ++ cProjectVersion),
+ ("span", json $ errMsgSpan m),
+ ("severity", json $ errMsgSeverity m),
+ ("code", maybe JSNull json (diagnosticCode diag)),
+ ("message", JSArray $ map renderToJSString diagMsg),
+ ("hints", JSArray $ map (renderToJSString . ppr) (diagnosticHints diag) )
+ ]
+ where diag = errMsgDiagnostic m
+ opts = defaultDiagnosticOpts @e
+ style = mkErrStyle (errMsgContext m)
+ ctx = defaultSDocContext {sdocStyle = style }
+ diagMsg = filter (not . isEmpty ctx) (unDecorated (diagnosticMessage (opts) diag))
+ renderToJSString :: SDoc -> JsonDoc
+ renderToJSString = JSString . (renderWithContext ctx)
+
instance Show (MsgEnvelope DiagnosticMessage) where
show = showMsgEnvelope
diff --git a/compiler/GHC/Types/SrcLoc.hs b/compiler/GHC/Types/SrcLoc.hs
index a78716a61ed4..18ba080f0b12 100644
--- a/compiler/GHC/Types/SrcLoc.hs
+++ b/compiler/GHC/Types/SrcLoc.hs
@@ -426,12 +426,14 @@ instance ToJson SrcSpan where
json (RealSrcSpan rss _) = json rss
instance ToJson RealSrcSpan where
- json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile))
- , ("startLine", JSInt srcSpanSLine)
- , ("startCol", JSInt srcSpanSCol)
- , ("endLine", JSInt srcSpanELine)
- , ("endCol", JSInt srcSpanECol)
+ json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile)),
+ ("start", start),
+ ("end", end)
]
+ where start = JSObject [ ("line", JSInt srcSpanSLine),
+ ("column", JSInt srcSpanSCol) ]
+ end = JSObject [ ("line", JSInt srcSpanELine),
+ ("column", JSInt srcSpanECol) ]
instance NFData SrcSpan where
rnf x = x `seq` ()
diff --git a/compiler/GHC/Utils/Logger.hs b/compiler/GHC/Utils/Logger.hs
index e1fc3832c312..f6db1880e195 100644
--- a/compiler/GHC/Utils/Logger.hs
+++ b/compiler/GHC/Utils/Logger.hs
@@ -24,6 +24,7 @@ module GHC.Utils.Logger
-- * Logger setup
, initLogger
, LogAction
+ , LogJsonAction
, DumpAction
, TraceAction
, DumpFormat (..)
@@ -31,6 +32,8 @@ module GHC.Utils.Logger
-- ** Hooks
, popLogHook
, pushLogHook
+ , popJsonLogHook
+ , pushJsonLogHook
, popDumpHook
, pushDumpHook
, popTraceHook
@@ -49,12 +52,13 @@ module GHC.Utils.Logger
, logVerbAtLeast
-- * Logging
- , jsonLogAction
, putLogMsg
, defaultLogAction
+ , defaultLogJsonAction
, defaultLogActionHPrintDoc
, defaultLogActionHPutStrDoc
, logMsg
+ , logJsonMsg
, logDumpMsg
-- * Dumping
@@ -87,6 +91,7 @@ import GHC.Utils.Panic
import GHC.Data.EnumSet (EnumSet)
import qualified GHC.Data.EnumSet as EnumSet
+import GHC.Data.FastString
import System.Directory
import System.FilePath ( takeDirectory, (</>) )
@@ -111,6 +116,7 @@ data LogFlags = LogFlags
, log_default_dump_context :: SDocContext
, log_dump_flags :: !(EnumSet DumpFlag) -- ^ Dump flags
, log_show_caret :: !Bool -- ^ Show caret in diagnostics
+ , log_diagnostics_as_json :: !Bool -- ^ Format diagnostics as JSON
, log_show_warn_groups :: !Bool -- ^ Show warning flag groups
, log_enable_timestamps :: !Bool -- ^ Enable timestamps
, log_dump_to_file :: !Bool -- ^ Enable dump to file
@@ -130,6 +136,7 @@ defaultLogFlags = LogFlags
, log_default_dump_context = defaultSDocContext
, log_dump_flags = EnumSet.empty
, log_show_caret = True
+ , log_diagnostics_as_json = False
, log_show_warn_groups = True
, log_enable_timestamps = True
, log_dump_to_file = False
@@ -177,6 +184,11 @@ type LogAction = LogFlags
-> SDoc
-> IO ()
+type LogJsonAction = LogFlags
+ -> MessageClass
+ -> JsonDoc
+ -> IO ()
+
type DumpAction = LogFlags
-> PprStyle
-> DumpFlag
@@ -214,6 +226,9 @@ data Logger = Logger
{ log_hook :: [LogAction -> LogAction]
-- ^ Log hooks stack
+ , json_log_hook :: [LogJsonAction -> LogJsonAction]
+ -- ^ Json log hooks stack
+
, dump_hook :: [DumpAction -> DumpAction]
-- ^ Dump hooks stack
@@ -249,6 +264,7 @@ initLogger = do
dumps <- newMVar Map.empty
return $ Logger
{ log_hook = []
+ , json_log_hook = []
, dump_hook = []
, trace_hook = []
, generated_dumps = dumps
@@ -260,6 +276,10 @@ initLogger = do
putLogMsg :: Logger -> LogAction
putLogMsg logger = foldr ($) defaultLogAction (log_hook logger)
+-- | Log a JsonDoc
+putJsonLogMsg :: Logger -> LogJsonAction
+putJsonLogMsg logger = foldr ($) defaultLogJsonAction (json_log_hook logger)
+
-- | Dump something
putDumpFile :: Logger -> DumpAction
putDumpFile logger =
@@ -284,6 +304,15 @@ popLogHook logger = case log_hook logger of
[] -> panic "popLogHook: empty hook stack"
_:hs -> logger { log_hook = hs }
+-- | Push a json log hook
+pushJsonLogHook :: (LogJsonAction -> LogJsonAction) -> Logger -> Logger
+pushJsonLogHook h logger = logger { json_log_hook = h:json_log_hook logger }
+
+popJsonLogHook :: Logger -> Logger
+popJsonLogHook logger = case json_log_hook logger of
+ [] -> panic "popJsonLogHook: empty hook stack"
+ _:hs -> logger { json_log_hook = hs}
+
-- | Push a dump hook
pushDumpHook :: (DumpAction -> DumpAction) -> Logger -> Logger
pushDumpHook h logger = logger { dump_hook = h:dump_hook logger }
@@ -328,7 +357,23 @@ makeThreadSafe logger = do
$ logger
-- See Note [JSON Error Messages]
---
+defaultLogJsonAction :: LogJsonAction
+defaultLogJsonAction logflags msg_class jsdoc =
+ case msg_class of
+ MCOutput -> printOut msg
+ MCDump -> printOut (msg $$ blankLine)
+ MCInteractive -> putStrSDoc msg
+ MCInfo -> printErrs msg
+ MCFatal -> printErrs msg
+ MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message
+ MCDiagnostic _sev _rea _code -> printErrs msg
+ where
+ printOut = defaultLogActionHPrintDoc logflags False stdout
+ printErrs = defaultLogActionHPrintDoc logflags False stderr
+ putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout
+ msg = renderJSON jsdoc
+-- See Note [JSON Error Messages]
+-- this is to be removed
jsonLogAction :: LogAction
jsonLogAction _ (MCDiagnostic SevIgnore _ _) _ _ = return () -- suppress the message
jsonLogAction logflags msg_class srcSpan msg
@@ -338,10 +383,20 @@ jsonLogAction logflags msg_class srcSpan msg
where
str = renderWithContext (log_default_user_context logflags) msg
doc = renderJSON $
- JSObject [ ( "span", json srcSpan )
+ JSObject [ ( "span", spanToDumpJSON srcSpan )
, ( "doc" , JSString str )
, ( "messageClass", json msg_class )
]
+ spanToDumpJSON :: SrcSpan -> JsonDoc
+ spanToDumpJSON s = case s of
+ (RealSrcSpan rss _) -> JSObject [ ("file", json file)
+ , ("startLine", json $ srcSpanStartLine rss)
+ , ("startCol", json $ srcSpanStartCol rss)
+ , ("endLine", json $ srcSpanEndLine rss)
+ , ("endCol", json $ srcSpanEndCol rss)
+ ]
+ where file = unpackFS $ srcSpanFile rss
+ UnhelpfulSpan _ -> JSNull
defaultLogAction :: LogAction
defaultLogAction logflags msg_class srcSpan msg
@@ -403,6 +458,12 @@ defaultLogActionHPutStrDoc logflags asciiSpace h d
-- information to provide to the user but refactoring log_action is quite
-- invasive as it is called in many places. So, for now I left it alone
-- and we can refine its behaviour as users request different output.
+--
+-- The recent work here replaces the purpose of flag -ddump-json with
+-- -fdiagnostics-as-json. For temporary backwards compatibility while
+-- -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.
-- | Default action for 'dumpAction' hook
defaultDumpAction :: DumpCache -> LogAction -> DumpAction
@@ -532,6 +593,9 @@ 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)
+
-- | Dump something
logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
logDumpFile logger = putDumpFile logger (logFlags logger)
diff --git a/docs/users_guide/debugging.rst b/docs/users_guide/debugging.rst
index 6de825c72014..3e22bc90d5b2 100644
--- a/docs/users_guide/debugging.rst
+++ b/docs/users_guide/debugging.rst
@@ -56,12 +56,11 @@ Dumping out compiler intermediate structures
output of one way with the output of another.
.. ghc-flag:: -ddump-json
- :shortdesc: Dump error messages as JSON documents
+ :shortdesc: *(deprecated)* Use :ghc-flag:`-fdiagnostics-as-json` instead
:type: dynamic
- Dump error messages as JSON documents. This is intended to be consumed
- by external tooling. A good way to use it is in conjunction with
- :ghc-flag:`-ddump-to-file`.
+ This flag was previously used to generated JSON formatted GHC diagnostics,
+ but has been deprecated. Instead, use :ghc-flag:`-fdiagnostics-as-json`.
.. ghc-flag:: -dshow-passes
:shortdesc: Print out each pass name as it happens
diff --git a/docs/users_guide/diagnostics-as-json-schema-1_0.json b/docs/users_guide/diagnostics-as-json-schema-1_0.json
new file mode 100644
index 000000000000..7ea8f77b4a49
--- /dev/null
+++ b/docs/users_guide/diagnostics-as-json-schema-1_0.json
@@ -0,0 +1,103 @@
+{
+ "$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": {
+ "$ref": "#/$defs/span"
+ },
+ "severity": {
+ "description": "The diagnostic severity",
+ "type": "string",
+ "enum": [
+ "Warning",
+ "Error"
+ ]
+ },
+ "code": {
+ "description": "The diagnostic code (if it exists)",
+ "type": [
+ "integer",
+ "null"
+ ]
+ },
+ "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"
+ }
+ }
+ },
+ "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
+ }
+ }
+}
diff --git a/docs/users_guide/using.rst b/docs/users_guide/using.rst
index e3ef975ef2e1..10b793bd85af 100644
--- a/docs/users_guide/using.rst
+++ b/docs/users_guide/using.rst
@@ -1403,6 +1403,19 @@ messages and in GHCi:
find the relevant errors or likely to ignore the warnings when they are
mixed with many other messages.
+.. ghc-flag:: -fdiagnostics-as-json
+ :shortdesc: Output diagnostics in Json format specified by JSON schema
+ :type: dynamic
+ :category: verbosity
+
+ Causes GHC to emit diagnostic messages in a standardized JSON format,
+ and output them directly to ``stderr``. The format follows the `JSON Lines <https://jsonlines.org>`_
+ convention, where each diagnostic is its own JSON object separated by
+ 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 <diagnostics-as-json-schema-1_0.json>`.
+
.. ghc-flag:: -fdiagnostics-color=⟨always|auto|never⟩
:shortdesc: Use colors in error messages
:type: dynamic
diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout
index c20d251fefa6..d6d82aa23ee3 100644
--- a/testsuite/tests/count-deps/CountDepsAst.stdout
+++ b/testsuite/tests/count-deps/CountDepsAst.stdout
@@ -151,6 +151,7 @@ GHC.Types.ForeignCall
GHC.Types.ForeignStubs
GHC.Types.GREInfo
GHC.Types.Hint
+GHC.Types.Hint.Ppr
GHC.Types.HpcInfo
GHC.Types.Id
GHC.Types.Id.Info
diff --git a/testsuite/tests/driver/T16167.stdout b/testsuite/tests/driver/T16167.stdout
index de6efddde95c..0f405b13ff28 100644
--- a/testsuite/tests/driver/T16167.stdout
+++ b/testsuite/tests/driver/T16167.stdout
@@ -1 +1,2 @@
+{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"}
{"span":{"file":"T16167.hs","startLine":1,"startCol":8,"endLine":1,"endCol":9},"doc":"parse error on input \u2018f\u2019","messageClass":"MCDiagnostic SevError ErrorWithoutFlag Just GHC-58481"}
diff --git a/testsuite/tests/driver/all.T b/testsuite/tests/driver/all.T
index d1abb823066a..a873e607cf62 100644
--- a/testsuite/tests/driver/all.T
+++ b/testsuite/tests/driver/all.T
@@ -273,13 +273,11 @@ test('T12752pass', normal, compile, ['-DSHOULD_PASS=1 -Wcpp-undef'])
test('T12955', normal, makefile_test, [])
test('T12971', [when(opsys('mingw32'), fragile(17945)), ignore_stdout], makefile_test, [])
-test('json', normal, compile_fail, ['-ddump-json'])
-
-# json2 test is sensitive to the LLVM not supported ouput from GHC. ANd the error
-# won't tell. It looks unrelated and is annoying to debug. Hence we disable the
-# warning to prevent spurious errors.
+test('json_dump', normal, compile_fail, ['-ddump-json'])
+test('json', normalise_version('ghc'), compile_fail, ['-fdiagnostics-as-json'])
+test('json_warn', normalise_version('ghc'), compile, ['-fdiagnostics-as-json -Wunused-matches'])
test('json2', normalise_version('base','ghc-prim'), compile, ['-ddump-types -ddump-json -Wno-unsupported-llvm-version'])
-test('T16167', [req_interp,exit_code(1)], run_command,
+test('T16167', [normalise_version('ghc'),req_interp,exit_code(1)], run_command,
['{compiler} -x hs -e ":set prog T16167.hs" -ddump-json T16167.hs'])
test('T13604', [], makefile_test, [])
test('T13604a',
diff --git a/testsuite/tests/driver/json.hs b/testsuite/tests/driver/json.hs
index 1a727fd7cc10..dfe869194fce 100644
--- a/testsuite/tests/driver/json.hs
+++ b/testsuite/tests/driver/json.hs
@@ -1,6 +1,9 @@
+{-# LANGUAGE NoEmptyCase #-}
module Foo where
import Data.List
-id1 :: a -> a
-id1 = 5
+f1 :: a -> a
+f1 x = 5
+
+f2 x = do case () of
diff --git a/testsuite/tests/driver/json.stderr b/testsuite/tests/driver/json.stderr
index e022f25c30a8..5fd0092e8e32 100644
--- a/testsuite/tests/driver/json.stderr
+++ b/testsuite/tests/driver/json.stderr
@@ -1 +1 @@
-{"span":{"file":"json.hs","startLine":6,"startCol":7,"endLine":6,"endCol":8},"doc":"\u2022 No instance for \u2018Num (a -> a)\u2019 arising from the literal \u20185\u2019\n (maybe you haven't applied a function to enough arguments?)\n\u2022 In the expression: 5\n In an equation for \u2018id1\u2019: id1 = 5","messageClass":"MCDiagnostic SevError ErrorWithoutFlag Just GHC-39999"}
+{"version":"1.0","ghcVersion":"ghc-9.9.20230817","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 EmptyCase"]}
diff --git a/testsuite/tests/driver/json2.stderr b/testsuite/tests/driver/json2.stderr
index 6c69d3288140..51e20faa0e05 100644
--- a/testsuite/tests/driver/json2.stderr
+++ b/testsuite/tests/driver/json2.stderr
@@ -1 +1,2 @@
-{"span":null,"doc":"TYPE SIGNATURES\n foo :: forall a. a -> a\nDependent modules: []\nDependent packages: [base-4.16.0.0]","messageClass":"MCOutput"}
+{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"}
+{"span":null,"doc":"TYPE SIGNATURES\n foo :: forall a. a -> a\nDependent modules: []\nDependent packages: [base-4.19.0.0]","messageClass":"MCOutput"}
diff --git a/testsuite/tests/driver/json_dump.hs b/testsuite/tests/driver/json_dump.hs
new file mode 100644
index 000000000000..1a727fd7cc10
--- /dev/null
+++ b/testsuite/tests/driver/json_dump.hs
@@ -0,0 +1,6 @@
+module Foo where
+
+import Data.List
+
+id1 :: a -> a
+id1 = 5
diff --git a/testsuite/tests/driver/json_dump.stderr b/testsuite/tests/driver/json_dump.stderr
new file mode 100644
index 000000000000..19d3f9993ab2
--- /dev/null
+++ b/testsuite/tests/driver/json_dump.stderr
@@ -0,0 +1,2 @@
+{"span":null,"doc":"-ddump-json is deprecated: Use `-fdiagnostics-as-json` instead","messageClass":"MCDiagnostic SevWarning WarningWithFlags Opt_WarnDeprecatedFlags :| [] Just GHC-53692"}
+{"span":{"file":"json_dump.hs","startLine":6,"startCol":7,"endLine":6,"endCol":8},"doc":"\u2022 No instance for \u2018Num (a -> a)\u2019 arising from the literal \u20185\u2019\n (maybe you haven't applied a function to enough arguments?)\n\u2022 In the expression: 5\n In an equation for \u2018id1\u2019: id1 = 5","messageClass":"MCDiagnostic SevError ErrorWithoutFlag Just GHC-39999"}
diff --git a/testsuite/tests/driver/json_warn.hs b/testsuite/tests/driver/json_warn.hs
new file mode 100644
index 000000000000..2de050a421c3
--- /dev/null
+++ b/testsuite/tests/driver/json_warn.hs
@@ -0,0 +1,4 @@
+module Foo where
+
+f :: Int -> Int
+f x = 5
diff --git a/testsuite/tests/driver/json_warn.stderr b/testsuite/tests/driver/json_warn.stderr
new file mode 100644
index 000000000000..369a63c952f2
--- /dev/null
+++ b/testsuite/tests/driver/json_warn.stderr
@@ -0,0 +1 @@
+{"version":"1.0","ghcVersion":"ghc-9.9.20230817","span":{"file":"json_warn.hs","start":{"line":4,"column":3},"end":{"line":4,"column":4}},"severity":"Warning","code":40910,"message":["Defined but not used: `x'"],"hints":[]}
--
GitLab