Simon Hengel pushed to branch wip/sol/remove-ddump-json at Glasgow Haskell Compiler / GHC Commits: 611f3f3b by Simon Hengel at 2025-08-10T10:12:54+07:00 Remove JSON logging - - - - - 7 changed files: - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Driver/Errors.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Monad.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Utils/Logger.hs - ghc/GHCi/UI.hs Changes: ===================================== compiler/GHC/Core/Opt/Monad.hs ===================================== @@ -368,7 +368,7 @@ msg msg = do name_ppr_ctx <- getNamePprCtx let m = case msg of MCDump doc -> MCDump (dump_sty doc) - MCDiagnostic span severity reason code doc -> UnsafeMCDiagnostic span severity reason code (err_sty doc) + UnsafeMCDiagnostic span severity reason code doc diagnostic -> UnsafeMCDiagnostic span severity reason code (err_sty doc) diagnostic MCOutput doc -> MCOutput (user_sty doc) MCFatal doc -> MCFatal (user_sty doc) MCInteractive doc -> MCInteractive (user_sty doc) ===================================== compiler/GHC/Driver/Errors.hs ===================================== @@ -47,18 +47,15 @@ printMessages logger msg_opts opts = mapM_ (printMessage logger msg_opts opts) . printMessage :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> MsgEnvelope a -> IO () printMessage logger msg_opts opts message = do - decorated <- decorateDiagnostic logflags (messageClass doc) location - if log_diags_as_json then do - let - rendered :: String - rendered = renderWithContext (log_default_user_context logflags) decorated - - jsonMessage :: JsonDoc - jsonMessage = jsonDiagnostic rendered message - - logJsonMsg logger (messageClass decorated) jsonMessage - else do - logMsg logger (messageClass decorated) + decorated <- decorateDiagnostic logflags location severity reason code doc + let + rendered :: String + rendered = renderWithContext (log_default_user_context logflags) decorated + + jsonMessage :: JsonDoc + jsonMessage = jsonDiagnostic rendered message + + logMsg logger $ UnsafeMCDiagnostic location severity reason code decorated jsonMessage where logflags :: LogFlags logflags = logFlags logger @@ -66,9 +63,6 @@ printMessage logger msg_opts opts message = do doc :: SDoc doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic) - messageClass :: SDoc -> Message - messageClass = UnsafeMCDiagnostic location severity (errMsgReason message) (diagnosticCode diagnostic) - style :: PprStyle style = mkErrStyle (errMsgContext message) @@ -84,6 +78,12 @@ printMessage logger msg_opts opts message = do severity :: Severity severity = errMsgSeverity message + reason :: ResolvedDiagnosticReason + reason = errMsgReason message + + code :: Maybe DiagnosticCode + code = diagnosticCode diagnostic + messageWithHints :: a -> SDoc messageWithHints e = let main_msg = formatBulleted $ diagnosticMessage msg_opts e @@ -93,21 +93,18 @@ printMessage logger msg_opts opts message = do hs -> main_msg $$ hang (text "Suggested fixes:") 2 (formatBulleted $ mkDecorated . map ppr $ hs) - log_diags_as_json :: Bool - log_diags_as_json = log_diagnostics_as_json (logFlags logger) - -decorateDiagnostic :: LogFlags -> Message -> SrcSpan -> IO SDoc -decorateDiagnostic logflags msg srcSpan = addCaret +decorateDiagnostic :: LogFlags -> SrcSpan -> Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> SDoc -> IO SDoc +decorateDiagnostic logflags span severity reason code doc = addCaret where -- Pretty print the warning flag, if any (#10752) message :: SDoc - message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg srcSpan + message = formatDiagnostic (log_show_warn_groups logflags) span severity reason code doc addCaret :: IO SDoc addCaret = do caretDiagnostic <- if log_show_caret logflags - then getCaretDiagnostic msg srcSpan + then getCaretDiagnostic severity span else pure empty return $ getPprStyle $ \style -> withPprStyle (setStyleColoured True style) ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -1445,9 +1445,9 @@ withDeferredDiagnostics f = do let deferDiagnostics _dflags !msg = do let action = logMsg logger msg case msg of - MCDiagnostic _ SevWarning _reason _code _ + MCDiagnostic _ SevWarning _reason _code -> atomicModifyIORef' warnings $ \(!i) -> (action: i, ()) - MCDiagnostic _ SevError _reason _code _ + MCDiagnostic _ SevError _reason _code -> atomicModifyIORef' errors $ \(!i) -> (action: i, ()) MCFatal _ -> atomicModifyIORef' fatals $ \(!i) -> (action: i, ()) ===================================== compiler/GHC/Driver/Monad.hs ===================================== @@ -23,8 +23,6 @@ module GHC.Driver.Monad ( modifyLogger, pushLogHookM, popLogHookM, - pushJsonLogHookM, - popJsonLogHookM, putLogMsgM, putMsgM, withTimingM, @@ -122,12 +120,6 @@ 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 ===================================== compiler/GHC/Types/Error.hs ===================================== @@ -70,7 +70,6 @@ module GHC.Types.Error , mapDecoratedSDoc , pprMessageBag - , mkLocMessageWarningGroups , formatLocMessage , formatFatalLocMessage , formatDiagnostic @@ -493,7 +492,7 @@ data Message -- ^ Log messages intended for end users. -- No file\/line\/column stuff. - | UnsafeMCDiagnostic SrcSpan Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) SDoc + | UnsafeMCDiagnostic SrcSpan Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) SDoc JsonDoc -- ^ Diagnostics from the compiler. This constructor is very powerful as -- it allows the construction of a 'Message' with a completely -- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such, @@ -509,8 +508,8 @@ data Message -- should always have a 'DiagnosticCode'. See Note [Diagnostic codes]. {-# COMPLETE MCOutput, MCFatal, MCInteractive, MCDump, MCInfo, MCDiagnostic #-} -pattern MCDiagnostic :: SrcSpan -> Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> SDoc -> Message -pattern MCDiagnostic span severity reason code doc <- UnsafeMCDiagnostic span severity reason code doc +pattern MCDiagnostic :: SrcSpan -> Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> Message +pattern MCDiagnostic span severity reason code <- UnsafeMCDiagnostic span severity reason code _diagnostic _json {- Note [Suppressing Messages] @@ -635,25 +634,9 @@ showMsgEnvelope err = pprMessageBag :: Bag SDoc -> SDoc pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) --- | Make an error message with location info, specifying whether to show --- warning groups (if applicable). -mkLocMessageWarningGroups - :: Bool -- ^ Print warning groups (if applicable)? - -> Message -- ^ message - -> SrcSpan -- ^ location - -> SDoc -mkLocMessageWarningGroups show_warn_groups msg locn - = case msg of - MCDiagnostic span severity reason code doc -> formatDiagnostic show_warn_groups span severity reason code doc - MCFatal doc -> formatFatalLocMessage locn doc - MCOutput doc -> formatLocMessage locn doc - MCInteractive doc -> formatLocMessage locn doc - MCDump doc -> formatLocMessage locn doc - MCInfo doc -> formatLocMessage locn doc - formatFatalLocMessage :: SrcSpan -> SDoc -> SDoc formatFatalLocMessage locn msg = sdocOption sdocColScheme $ \col_scheme -> - let msg_title = coloured (fatalColour col_scheme) $ text "fatal" + let msg_title = coloured (Col.sFatal col_scheme) $ text "fatal" in formatLocMessageWarningGroups locn msg_title empty empty msg formatLocMessage :: SrcSpan -> SDoc -> SDoc @@ -770,23 +753,15 @@ formatLocMessageWarningGroups locn msg_title code_doc warning_flag_doc msg in coloured (Col.sMessage col_scheme) $ hang (coloured (Col.sHeader col_scheme) header) 4 msg -getMessageClassColour :: Message -> Col.Scheme -> Col.PprColour -getMessageClassColour (MCDiagnostic _span severity _reason _code _) = getSeverityColour severity -getMessageClassColour (MCFatal _) = fatalColour -getMessageClassColour _ = const mempty - -fatalColour :: Col.Scheme -> Col.PprColour -fatalColour = Col.sFatal - getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour getSeverityColour severity = case severity of SevError -> Col.sError SevWarning -> Col.sWarning SevIgnore -> const mempty -getCaretDiagnostic :: Message -> SrcSpan -> IO SDoc +getCaretDiagnostic :: Severity -> SrcSpan -> IO SDoc getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty -getCaretDiagnostic msg (RealSrcSpan span _) = +getCaretDiagnostic severity (RealSrcSpan span _) = caretDiagnostic <$> getSrcLine (srcSpanFile span) row where getSrcLine fn i = @@ -819,7 +794,7 @@ getCaretDiagnostic msg (RealSrcSpan span _) = caretDiagnostic Nothing = empty caretDiagnostic (Just srcLineWithNewline) = sdocOption sdocColScheme$ \col_scheme -> - let sevColour = getMessageClassColour msg col_scheme + let sevColour = getSeverityColour severity col_scheme marginColour = Col.sMargin col_scheme in coloured marginColour (text marginSpace) <> ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -24,7 +24,6 @@ module GHC.Utils.Logger -- * Logger setup , initLogger , LogAction - , LogJsonAction , DumpAction , TraceAction , DumpFormat (..) @@ -32,8 +31,6 @@ module GHC.Utils.Logger -- ** Hooks , popLogHook , pushLogHook - , popJsonLogHook - , pushJsonLogHook , popDumpHook , pushDumpHook , popTraceHook @@ -55,11 +52,9 @@ module GHC.Utils.Logger , putLogMsg , defaultLogAction , defaultLogActionWithHandles - , defaultLogJsonAction , defaultLogActionHPrintDoc , defaultLogActionHPutStrDoc , logMsg - , logJsonMsg , logDumpMsg -- * Dumping @@ -86,8 +81,8 @@ import GHC.Types.Error import qualified GHC.Utils.Ppr as Pretty import GHC.Utils.Outputable -import GHC.Utils.Json import GHC.Utils.Panic +import GHC.Utils.Json (renderJSON) import GHC.Data.EnumSet (EnumSet) import qualified GHC.Data.EnumSet as EnumSet @@ -181,11 +176,6 @@ type LogAction = LogFlags -> Message -> IO () -type LogJsonAction = LogFlags - -> Message - -> JsonDoc - -> IO () - type DumpAction = LogFlags -> PprStyle -> DumpFlag @@ -223,9 +213,6 @@ 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 @@ -261,7 +248,6 @@ initLogger = do dumps <- newMVar Map.empty return $ Logger { log_hook = [] - , json_log_hook = [] , dump_hook = [] , trace_hook = [] , generated_dumps = dumps @@ -273,10 +259,6 @@ 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 = @@ -301,15 +283,6 @@ 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 } @@ -353,22 +326,6 @@ makeThreadSafe logger = do $ pushTraceHook trc $ logger -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 _span _sev _rea _code _ -> printErrs msg - where - printOut = defaultLogActionHPrintDoc logflags False stdout - printErrs = defaultLogActionHPrintDoc logflags False stderr - putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout - msg = renderJSON jsdoc - -- | The default 'LogAction' prints to 'stdout' and 'stderr'. -- -- To replicate the default log action behaviour with different @out@ and @err@ @@ -386,8 +343,12 @@ defaultLogActionWithHandles out err logflags message MCInteractive msg -> putStrSDoc msg MCInfo msg -> printErrs msg MCFatal msg -> printErrs msg - MCDiagnostic _ SevIgnore _ _ _ -> pure () -- suppress the message - MCDiagnostic _span _sev _rea _code msg -> printErrs msg + MCDiagnostic _ SevIgnore _ _ -> pure () -- suppress the message + UnsafeMCDiagnostic _span _severity _reason _code doc json -> do + if log_diagnostics_as_json logflags then do + printErrs (renderJSON json) + else do + printErrs doc where printOut = defaultLogActionHPrintDoc logflags False out printErrs = defaultLogActionHPrintDoc logflags False err @@ -534,9 +495,6 @@ defaultTraceAction logflags title doc x = logMsg :: Logger -> Message -> IO () logMsg logger = putLogMsg logger (logFlags logger) -logJsonMsg :: Logger -> Message -> JsonDoc -> IO () -logJsonMsg logger mc = putJsonLogMsg logger (logFlags logger) mc - -- | Dump something logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () logDumpFile logger = putDumpFile logger (logFlags logger) ===================================== ghc/GHCi/UI.hs ===================================== @@ -836,7 +836,7 @@ ghciLogAction lastErrLocations old_log_action dflags msg = do old_log_action dflags msg case msg of - MCDiagnostic srcSpan SevError _reason _code _ -> case srcSpan of + MCDiagnostic srcSpan SevError _reason _code -> case srcSpan of RealSrcSpan rsp _ -> modifyIORef lastErrLocations (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))]) _ -> return () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/611f3f3b4e9bf7eeabc814f5668e1b28... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/611f3f3b4e9bf7eeabc814f5668e1b28... You're receiving this email because of your account on gitlab.haskell.org.