[Git][ghc/ghc][wip/sol/add-rendered-to-json-diagnostics] wip

7 Jul 2025


      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
wip

- - - - -


2 changed files:

- compiler/GHC/Driver/Errors.hs
- compiler/GHC/Utils/Logger.hs


Changes:

=====================================
compiler/GHC/Driver/Errors.hs
=====================================
@@ -11,8 +11,9 @@ import GHC.Driver.Errors.Types
 import GHC.Prelude
 import GHC.Types.SourceError
 import GHC.Types.Error
+import GHC.Utils.Json
 import GHC.Utils.Error
-import GHC.Utils.Outputable (SDocContext, PprStyle, 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 ()
@@ -23,9 +24,26 @@ printMessages logger msg_opts opts = mapM_ printMessage . sortMessages
 
     printMessage :: MsgEnvelope a -> IO ()
     printMessage message
-      | log_diags_as_json = logJsonMsg logger messageClass 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)
 


=====================================
compiler/GHC/Utils/Logger.hs
=====================================
@@ -21,6 +21,8 @@ module GHC.Utils.Logger
     , HasLogger (..)
     , ContainsLogger (..)
 
+    , addCaret
+
     -- * Logger setup
     , initLogger
     , LogAction
@@ -435,18 +437,17 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg
       message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg
 
       printDiagnostics :: IO ()
-      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 = addCaret logflags msg_class srcSpan message >>= printErrs
+
+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 ()
@@ -611,8 +612,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 ()



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3ce82ba0e362a8ae82c2e3c7bac6186f...

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3ce82ba0e362a8ae82c2e3c7bac6186f...
You're receiving this email because of your account on gitlab.haskell.org.

    

Simon Hengel (＠sol)

tags

participants (1)