Simon Hengel pushed to branch wip/sol/add-rendered-to-json-diagnostics at Glasgow Haskell Compiler / GHC Commits: b9d5fc48 by Simon Hengel at 2025-07-08T03:36:56+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 () @@ -22,10 +23,28 @@ printMessages logger msg_opts opts = mapM_ printMessage . sortMessages sortMessages = sortMsgBag (Just opts) . getMessages printMessage :: MsgEnvelope a -> IO () - printMessage message - | log_diags_as_json = logJsonMsg logger messageClass message - | otherwise = logMsg logger messageClass location doc + printMessage message = do + doc_ <- addCaret logflags messageClass location (addHeader doc) + + let + rendered :: String + rendered = renderWithContext (log_default_user_context logflags) doc_ + + jsonMessage :: JsonDoc + jsonMessage = case json message of + JSObject xs -> JSObject (("rendered", JSString rendered) : xs) + xs -> xs + + case log_diags_as_json of + True -> logJsonMsg logger messageClass jsonMessage + False -> 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/b9d5fc4809080844f9a6e2c1029fc027... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b9d5fc4809080844f9a6e2c1029fc027... You're receiving this email because of your account on gitlab.haskell.org.