Simon Hengel pushed to branch wip/sol/add-rendered-to-json-diagnostics at Glasgow Haskell Compiler / GHC Commits: 805d5f0b by Simon Hengel at 2025-07-08T04:44:31+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,51 @@ 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 + +-- 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 () @@ -482,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 @@ -611,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 () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/805d5f0bb699fa91b9fba35171699480... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/805d5f0bb699fa91b9fba35171699480... You're receiving this email because of your account on gitlab.haskell.org.