[Git][ghc/ghc][wip/sol/remove-ddump-json] 8 commits: Remove -ddump-json (fixes #24113)

22 Aug 2025

Simon Hengel pushed to branch wip/sol/remove-ddump-json at Glasgow Haskell Compiler / GHC


Commits:
961bb596 by Simon Hengel at 2025-08-22T21:38:01+07:00
Remove -ddump-json (fixes #24113)

- - - - -
e991a4f1 by Simon Hengel at 2025-08-22T21:38:01+07:00
Add SrcSpan to MCDiagnostic

- - - - -
2aa43ad0 by Simon Hengel at 2025-08-22T21:38:01+07:00
Refactoring: More consistently use logOutput, logInfo, fatalErrorMsg

- - - - -
54009c0e by Simon Hengel at 2025-08-22T21:38:01+07:00
Get rid of mkLocMessage

- - - - -
d8a4c402 by Simon Hengel at 2025-08-22T21:38:01+07:00
Add Message data type

- - - - -
638ca476 by Simon Hengel at 2025-08-22T21:38:02+07:00
Get rid of MessageClass

- - - - -
3c86056e by Simon Hengel at 2025-08-22T21:38:02+07:00
Remove JSON logging

- - - - -
95790a5c by Simon Hengel at 2025-08-22T21:38:02+07:00
Update `testsuite/tests/plugins/hooks-plugin/Hooks/LogPlugin.hs`

- - - - -


30 changed files:

- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/Monad.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Errors.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Monad.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Pipeline/LogQueue.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Debugger.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Error.hs
- compiler/GHC/Utils/Error.hs
- compiler/GHC/Utils/Logger.hs
- docs/users_guide/debugging.rst
- ghc/GHCi/UI.hs
- testsuite/tests/driver/T16167.stderr
- − testsuite/tests/driver/T16167.stdout
- testsuite/tests/driver/all.T
- testsuite/tests/driver/json2.stderr
- − testsuite/tests/driver/json_dump.hs
- − testsuite/tests/driver/json_dump.stderr
- testsuite/tests/ghc-api/T7478/T7478.hs
- testsuite/tests/plugins/hooks-plugin/Hooks/LogPlugin.hs


Changes:

=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -26,6 +26,7 @@ module GHC.Core.Lint (
     -- ** Debug output
     EndPassConfig (..),
     endPassIO,
+    lintMessage,
     displayLintResults, dumpPassResult
  ) where
 
@@ -309,11 +310,6 @@ path does not result in allocation in the hot path. This can be surprisingly
 impactful. Changing `lint_app` reduced allocations for one test program I was
 looking at by ~4%.
 
-Note [MCInfo for Lint]
-~~~~~~~~~~~~~~~~~~~~~~
-When printing a Lint message, use the MCInfo severity so that the
-message is printed on stderr rather than stdout (#13342).
-
 ************************************************************************
 *                                                                      *
                  Beginning and ending passes
@@ -321,6 +317,12 @@ message is printed on stderr rather than stdout (#13342).
 ************************************************************************
 -}
 
+lintMessage :: Logger -> SDoc -> IO ()
+lintMessage logger =
+  -- Note: Use logInfo when printing a Lint message, so that the message is
+  -- printed on stderr rather than stdout (#13342).
+  logInfo logger . withPprStyle defaultDumpStyle
+
 -- | Configuration for boilerplate operations at the end of a
 -- compilation pass producing Core.
 data EndPassConfig = EndPassConfig
@@ -436,8 +438,7 @@ displayLintResults :: Logger
                    -> IO ()
 displayLintResults logger display_warnings pp_what pp_pgm (warns, errs)
   | not (isEmptyBag errs)
-  = do { logMsg logger Err.MCInfo noSrcSpan  -- See Note [MCInfo for Lint]
-           $ withPprStyle defaultDumpStyle
+  = do { lintMessage logger
            (vcat [ lint_banner "errors" pp_what, Err.pprMessageBag errs
                  , text "*** Offending Program ***"
                  , pp_pgm
@@ -447,8 +448,7 @@ displayLintResults logger display_warnings pp_what pp_pgm (warns, errs)
   | not (isEmptyBag warns)
   , log_enable_debug (logFlags logger)
   , display_warnings
-  = logMsg logger Err.MCInfo noSrcSpan  -- See Note [MCInfo for Lint]
-      $ withPprStyle defaultDumpStyle
+  = lintMessage logger
         (lint_banner "warnings" pp_what $$ Err.pprMessageBag (mapBag ($$ blankLine) warns))
 
   | otherwise = return ()


=====================================
compiler/GHC/Core/Opt/Monad.hs
=====================================
@@ -362,19 +362,22 @@ we aren't using annotations heavily.
 ************************************************************************
 -}
 
-msg :: MessageClass -> SDoc -> CoreM ()
-msg msg_class doc = do
+msg :: Message -> CoreM ()
+msg msg = do
     logger <- getLogger
-    loc    <- getSrcSpanM
     name_ppr_ctx <- getNamePprCtx
-    let sty = case msg_class of
-                MCDiagnostic _ _ _ -> err_sty
-                MCDump             -> dump_sty
-                _                  -> user_sty
-        err_sty  = mkErrStyle name_ppr_ctx
-        user_sty = mkUserStyle name_ppr_ctx AllTheWay
-        dump_sty = mkDumpStyle name_ppr_ctx
-    liftIO $ logMsg logger msg_class loc (withPprStyle sty doc)
+    let m = case msg of
+                MCDump doc -> MCDump (dump_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)
+                MCInfo doc -> MCInfo (user_sty doc)
+
+        err_sty  = withPprStyle $ mkErrStyle name_ppr_ctx
+        user_sty = withPprStyle $ mkUserStyle name_ppr_ctx AllTheWay
+        dump_sty = withPprStyle $ mkDumpStyle name_ppr_ctx
+    liftIO $ logMsg logger m
 
 -- | Output a String message to the screen
 putMsgS :: String -> CoreM ()
@@ -382,7 +385,7 @@ putMsgS = putMsg . text
 
 -- | Output a message to the screen
 putMsg :: SDoc -> CoreM ()
-putMsg = msg MCInfo
+putMsg = msg . MCInfo
 
 diagnostic :: DiagnosticReason -> SDoc -> CoreM ()
 diagnostic reason doc = do
@@ -407,7 +410,7 @@ fatalErrorMsgS = fatalErrorMsg . text
 
 -- | Output a fatal error to the screen. Does not cause the compiler to die.
 fatalErrorMsg :: SDoc -> CoreM ()
-fatalErrorMsg = msg MCFatal
+fatalErrorMsg = msg . MCFatal
 
 -- | Output a string debugging message at verbosity level of @-v@ or higher
 debugTraceMsgS :: String -> CoreM ()
@@ -415,4 +418,4 @@ debugTraceMsgS = debugTraceMsg . text
 
 -- | Outputs a debugging message at verbosity level of @-v@ or higher
 debugTraceMsg :: SDoc -> CoreM ()
-debugTraceMsg = msg MCDump
+debugTraceMsg = msg . MCDump


=====================================
compiler/GHC/Driver/CodeOutput.hs
=====================================
@@ -18,6 +18,7 @@ import GHC.Prelude
 import GHC.Platform
 import GHC.ForeignSrcLang
 import GHC.Data.FastString
+import GHC.Core.Lint ( lintMessage )
 
 import GHC.CmmToAsm     ( nativeCodeGen )
 import GHC.CmmToLlvm    ( llvmCodeGen )
@@ -55,7 +56,6 @@ import GHC.Utils.Panic.Plain ( pgmError )
 import GHC.Unit
 import GHC.Unit.Finder      ( mkStubPaths )
 
-import GHC.Types.SrcLoc
 import GHC.Types.CostCentre
 import GHC.Types.ForeignStubs
 import GHC.Types.Unique.DSM
@@ -109,10 +109,7 @@ codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location g
                   (text "CmmLint"<+>brackets (ppr this_mod))
                   (const ()) $ do
                 { case cmmLint (targetPlatform dflags) cmm of
-                        Just err -> do { logMsg logger
-                                                   MCInfo -- See Note [MCInfo for Lint] in "GHC.Core.Lint"
-                                                   noSrcSpan
-                                                   $ withPprStyle defaultDumpStyle err
+                        Just err -> do { lintMessage logger err
                                        ; ghcExit logger 1
                                        }
                         Nothing  -> return ()


=====================================
compiler/GHC/Driver/Errors.hs
=====================================
@@ -46,19 +46,16 @@ printMessages logger msg_opts opts = mapM_ (printMessage logger msg_opts opts) .
     sortMessages = sortMsgBag (Just opts) . getMessages
 
 printMessage :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> MsgEnvelope a -> IO ()
-printMessage logger msg_opts opts message
-  | log_diags_as_json = do
-      decorated <- decorateDiagnostic logflags messageClass location doc
-      let
-        rendered :: String
-        rendered = renderWithContext (log_default_user_context logflags) decorated
-
-        jsonMessage :: JsonDoc
-        jsonMessage = jsonDiagnostic rendered message
+printMessage logger msg_opts opts message = do
+  decorated <- decorateDiagnostic logflags location severity reason code doc
+  let
+    rendered :: String
+    rendered = renderWithContext (log_default_user_context logflags) decorated
 
-      logJsonMsg logger messageClass jsonMessage
+    jsonMessage :: JsonDoc
+    jsonMessage = jsonDiagnostic rendered message
 
-  | otherwise = logMsg logger messageClass location doc
+  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
     doc :: SDoc
     doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic)
 
-    messageClass :: MessageClass
-    messageClass = UnsafeMCDiagnostic severity (errMsgReason message) (diagnosticCode diagnostic)
-
     style :: PprStyle
     style = mkErrStyle (errMsgContext message)
 
@@ -84,6 +78,12 @@ printMessage logger msg_opts opts message
     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,8 +93,22 @@ printMessage logger msg_opts opts message
                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 -> 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 = formatDiagnostic (log_show_warn_groups logflags) span severity reason code doc
+
+    addCaret :: IO SDoc
+    addCaret = do
+      caretDiagnostic <-
+          if log_show_caret logflags
+          then getCaretDiagnostic severity span
+          else pure empty
+      return $ getPprStyle $ \style ->
+        withPprStyle (setStyleColoured True style)
+          (message $+$ caretDiagnostic $+$ blankLine)
 
 -- | Given a bag of diagnostics, turn them into an exception if
 -- any has 'SevError', or print them out otherwise.


=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -526,7 +526,6 @@ data DumpFlag
    | Opt_D_dump_view_pattern_commoning
    | Opt_D_verbose_core2core
    | Opt_D_dump_debug
-   | Opt_D_dump_json
    | Opt_D_ppr_debug
    | Opt_D_no_debug_output
    | Opt_D_dump_faststrings


=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -1835,7 +1835,7 @@ markUnsafeInfer tcg_env whyUnsafe = do
                          ]
     badFlags df   = concatMap (badFlag df) unsafeFlagsForInfer
     badFlag df (ext,loc,on,_)
-        | on df     = [mkLocMessage MCOutput (loc df) $
+        | on df     = [formatLocMessage (loc df) $
                             text "-X" <> ppr ext <+> text "is not allowed in Safe Haskell"]
         | otherwise = []
     badInsts insts = concatMap badInst insts
@@ -1844,9 +1844,10 @@ markUnsafeInfer tcg_env whyUnsafe = do
     checkOverlap _             = True
 
     badInst ins | checkOverlap (overlapMode (is_flag ins))
-                = [mkLocMessage MCOutput (nameSrcSpan $ getName $ is_dfun ins) $
+                = [formatLocMessage (nameSrcSpan $ getName $ is_dfun ins) $
                       ppr (overlapMode $ is_flag ins) <+>
-                      text "overlap mode isn't allowed in Safe Haskell"]
+                      text "overlap mode isn't allowed in Safe Haskell"
+                      ]
                 | otherwise = []
 
 -- | Figure out the final correct safe haskell mode


=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1442,14 +1442,14 @@ withDeferredDiagnostics f = do
     fatals <- liftIO $ newIORef []
     logger <- getLogger
 
-    let deferDiagnostics _dflags !msgClass !srcSpan !msg = do
-          let action = logMsg logger msgClass srcSpan msg
-          case msgClass of
-            MCDiagnostic SevWarning _reason _code
+    let deferDiagnostics _dflags !msg = do
+          let action = logMsg logger msg
+          case msg of
+            MCDiagnostic _ SevWarning _reason _code
               -> atomicModifyIORef' warnings $ \(!i) -> (action: i, ())
-            MCDiagnostic SevError _reason _code
+            MCDiagnostic _ SevError _reason _code
               -> atomicModifyIORef' errors   $ \(!i) -> (action: i, ())
-            MCFatal
+            MCFatal _
               -> atomicModifyIORef' fatals   $ \(!i) -> (action: i, ())
             _ -> action
 


=====================================
compiler/GHC/Driver/Monad.hs
=====================================
@@ -23,8 +23,6 @@ module GHC.Driver.Monad (
         modifyLogger,
         pushLogHookM,
         popLogHookM,
-        pushJsonLogHookM,
-        popJsonLogHookM,
         putLogMsgM,
         putMsgM,
         withTimingM,
@@ -47,7 +45,6 @@ import GHC.Utils.Exception
 import GHC.Utils.Error
 import GHC.Utils.Logger
 
-import GHC.Types.SrcLoc
 import GHC.Types.SourceError
 
 import Control.Monad
@@ -123,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
@@ -136,10 +127,10 @@ putMsgM doc = do
     liftIO $ putMsg logger doc
 
 -- | Put a log message
-putLogMsgM :: GhcMonad m => MessageClass -> SrcSpan -> SDoc -> m ()
-putLogMsgM msg_class loc doc = do
+putLogMsgM :: GhcMonad m => Message -> m ()
+putLogMsgM message = do
     logger <- getLogger
-    liftIO $ logMsg logger msg_class loc doc
+    liftIO $ logMsg logger message
 
 -- | Time an action
 withTimingM :: GhcMonad m => SDoc -> (b -> ()) -> m b -> m b


=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -1162,7 +1162,7 @@ getHCFilePackages filename =
 linkDynLibCheck :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()
 linkDynLibCheck logger tmpfs dflags unit_env o_files dep_units = do
   when (haveRtsOptsFlags dflags) $
-    logMsg logger MCInfo noSrcSpan
+    logInfo logger
       $ withPprStyle defaultUserStyle
       (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$
       text "    Call hs_init_ghc() from your main() function to set these options.")


=====================================
compiler/GHC/Driver/Pipeline/LogQueue.hs
=====================================
@@ -18,7 +18,6 @@ import GHC.Prelude
 import Control.Concurrent
 import Data.IORef
 import GHC.Types.Error
-import GHC.Types.SrcLoc
 import GHC.Utils.Logger
 import qualified Data.IntMap as IM
 import Control.Concurrent.STM
@@ -30,7 +29,7 @@ import Control.Monad
 -- to. A 'Nothing' value contains the result of compilation, and denotes the
 -- end of the message queue.
 data LogQueue = LogQueue { logQueueId :: !Int
-                         , logQueueMessages :: !(IORef [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)])
+                         , logQueueMessages :: !(IORef [Maybe (Message, LogFlags)])
                          , logQueueSemaphore :: !(MVar ())
                          }
 
@@ -45,12 +44,12 @@ finishLogQueue lq = do
   writeLogQueueInternal lq Nothing
 
 
-writeLogQueue :: LogQueue -> (MessageClass,SrcSpan,SDoc, LogFlags) -> IO ()
+writeLogQueue :: LogQueue -> (Message, LogFlags) -> IO ()
 writeLogQueue lq msg = do
   writeLogQueueInternal lq (Just msg)
 
 -- | Internal helper for writing log messages
-writeLogQueueInternal :: LogQueue -> Maybe (MessageClass,SrcSpan,SDoc, LogFlags) -> IO ()
+writeLogQueueInternal :: LogQueue -> Maybe (Message, LogFlags) -> IO ()
 writeLogQueueInternal (LogQueue _n ref sem) msg = do
     atomicModifyIORef' ref $ \msgs -> (msg:msgs,())
     _ <- tryPutMVar sem ()
@@ -59,8 +58,8 @@ writeLogQueueInternal (LogQueue _n ref sem) msg = do
 -- The log_action callback that is used to synchronize messages from a
 -- worker thread.
 parLogAction :: LogQueue -> LogAction
-parLogAction log_queue log_flags !msgClass !srcSpan !msg =
-    writeLogQueue log_queue (msgClass,srcSpan,msg, log_flags)
+parLogAction log_queue log_flags !msg =
+    writeLogQueue log_queue (msg, log_flags)
 
 -- Print each message from the log_queue using the global logger
 printLogs :: Logger -> LogQueue -> IO ()
@@ -72,8 +71,8 @@ printLogs !logger (LogQueue _n ref sem) = read_msgs
 
         print_loop [] = read_msgs
         print_loop (x:xs) = case x of
-            Just (msgClass,srcSpan,msg,flags) -> do
-                logMsg (setLogFlags logger flags) msgClass srcSpan msg
+            Just (msg,flags) -> do
+                logMsg (setLogFlags logger flags) msg
                 print_loop xs
             -- Exit the loop once we encounter the end marker.
             Nothing -> return ()


=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -1657,9 +1657,6 @@ dynamic_flags_deps = [
         (NoArg (setGeneralFlag Opt_NoTypeableBinds))
   , make_ord_flag defGhcFlag "ddump-debug"
         (setDumpFlag Opt_D_dump_debug)
-  , 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"


=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -94,7 +94,6 @@ import GHC.Types.SourceFile
 import GHC.Types.SafeHaskell
 import GHC.Types.TypeEnv
 import GHC.Types.Unique.DSet
-import GHC.Types.SrcLoc
 import GHC.Types.TyThing
 import GHC.Types.PkgQual
 
@@ -1105,7 +1104,7 @@ For some background on this choice see #15269.
 showIface :: Logger -> DynFlags -> UnitState -> NameCache -> FilePath -> IO ()
 showIface logger dflags unit_state name_cache filename = do
    let profile = targetProfile dflags
-       printer = logMsg logger MCOutput noSrcSpan . withPprStyle defaultDumpStyle
+       printer = logOutput logger . withPprStyle defaultDumpStyle
 
    -- skip the hi way check; we don't want to worry about profiled vs.
    -- non-profiled interfaces, for example.
@@ -1119,7 +1118,7 @@ showIface logger dflags unit_state name_cache filename = do
                                    neverQualifyModules
                                    neverQualifyPackages
                                    alwaysPrintPromTick
-   logMsg logger MCDump noSrcSpan
+   logMsg logger $ MCDump
       $ withPprStyle (mkDumpStyle name_ppr_ctx)
       $ pprModIface unit_state iface
 


=====================================
compiler/GHC/Linker/Deps.hs
=====================================
@@ -25,6 +25,7 @@ import GHC.Linker.Types
 import GHC.Types.SrcLoc
 import GHC.Types.Unique.DSet
 import GHC.Types.Unique.DFM
+import GHC.Types.Error (formatFatalLocMessage)
 
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
@@ -231,7 +232,7 @@ splice point about what we would prefer.
 -}
 
 dieWith :: LinkDepsOpts -> SrcSpan -> SDoc -> IO a
-dieWith opts span msg = throwProgramError opts (mkLocMessage MCFatal span msg)
+dieWith opts span msg = throwProgramError opts (formatFatalLocMessage span msg)
 
 throwProgramError :: LinkDepsOpts -> SDoc -> IO a
 throwProgramError opts doc = throwGhcExceptionIO (ProgramError (renderWithContext (ldPprOpts opts) doc))


=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -507,7 +507,7 @@ classifyLdInput logger platform f
   | isObjectFilename platform f = return (Just (Objects [f]))
   | isDynLibFilename platform f = return (Just (DLLPath f))
   | otherwise          = do
-        logMsg logger MCInfo noSrcSpan
+        logInfo logger
             $ withPprStyle defaultUserStyle
             (text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))
         return Nothing
@@ -1638,9 +1638,8 @@ addEnvPaths name list
 maybePutSDoc :: Logger -> SDoc -> IO ()
 maybePutSDoc logger s
     = when (logVerbAtLeast logger 2) $
-          logMsg logger
+          logMsg logger $
               MCInteractive
-              noSrcSpan
               $ withPprStyle defaultUserStyle s
 
 maybePutStr :: Logger -> String -> IO ()


=====================================
compiler/GHC/Runtime/Debugger.hs
=====================================
@@ -209,7 +209,7 @@ showTerm term = do
                 setSession new_env
 
                 -- this disables logging of errors
-                let noop_log _ _ _ _ = return ()
+                let noop_log _ _ = return ()
                 pushLogHookM (const noop_log)
 
                 return (hsc_env, bname)


=====================================
compiler/GHC/Stg/Lint.hs
=====================================
@@ -104,6 +104,7 @@ import GHC.Stg.Utils
 import GHC.Core.DataCon
 import GHC.Core             ( AltCon(..) )
 import GHC.Core.Type
+import GHC.Core.Lint        ( lintMessage )
 
 import GHC.Types.Basic      ( TopLevelFlag(..), isTopLevel, isMarkedCbv )
 import GHC.Types.CostCentre ( isCurrentCCS )
@@ -148,8 +149,7 @@ lintStgTopBindings platform logger diag_opts opts extra_vars this_mod unarised w
       Nothing  ->
         return ()
       Just msg -> do
-        logMsg logger Err.MCInfo noSrcSpan   -- See Note [MCInfo for Lint] in "GHC.Core.Lint"
-          $ withPprStyle defaultDumpStyle
+        lintMessage logger
           (vcat [ text "*** Stg Lint ErrMsgs: in" <+>
                         text whodunit <+> text "***",
                   msg,


=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -864,7 +864,7 @@ wrapDocLoc doc = do
   if logHasDumpFlag logger Opt_D_ppr_debug
     then do
       loc <- getSrcSpanM
-      return (mkLocMessage MCOutput loc doc)
+      return (formatLocMessage loc doc)
     else
       return doc
 
@@ -2343,8 +2343,7 @@ failIfM msg = do
     env <- getLclEnv
     let full_msg = (if_loc env <> colon) $$ nest 2 msg
     logger <- getLogger
-    liftIO (logMsg logger MCFatal
-             noSrcSpan $ withPprStyle defaultErrStyle full_msg)
+    liftIO $ fatalErrorMsg logger full_msg
     failM
 
 --------------------
@@ -2376,10 +2375,7 @@ forkM doc thing_inside
                       logger <- getLogger
                       let msg = hang (text "forkM failed:" <+> doc)
                                    2 (text (show exn))
-                      liftIO $ logMsg logger
-                                         MCFatal
-                                         noSrcSpan
-                                         $ withPprStyle defaultErrStyle msg
+                      liftIO $ fatalErrorMsg logger msg
                 ; traceIf (text "} ending fork (badly)" <+> doc)
                 ; pgmError "Cannot continue after interface file error" }
     }


=====================================
compiler/GHC/Types/Error.hs
=====================================
@@ -26,7 +26,7 @@ module GHC.Types.Error
 
    -- * Classifying Messages
 
-   , MessageClass (MCDiagnostic, ..)
+   , Message (MCDiagnostic, ..)
    , Severity (..)
    , Diagnostic (..)
    , UnknownDiagnostic (..)
@@ -70,8 +70,8 @@ module GHC.Types.Error
    , mapDecoratedSDoc
 
    , pprMessageBag
-   , mkLocMessage
-   , mkLocMessageWarningGroups
+   , formatLocMessage
+   , formatFatalLocMessage
    , formatDiagnostic
    , getCaretDiagnostic
 
@@ -479,22 +479,22 @@ data MsgEnvelope e = MsgEnvelope
 -- | The class for a diagnostic message. The main purpose is to classify a
 -- message within GHC, to distinguish it from a debug/dump message vs a proper
 -- diagnostic, for which we include a 'DiagnosticReason'.
-data MessageClass
-  = MCOutput
-  | MCFatal
-  | MCInteractive
+data Message
+  = MCOutput SDoc
+  | MCFatal SDoc
+  | MCInteractive SDoc
 
-  | MCDump
+  | MCDump SDoc
     -- ^ Log message intended for compiler developers
     -- No file\/line\/column stuff
 
-  | MCInfo
+  | MCInfo SDoc
     -- ^ Log messages intended for end users.
     -- No file\/line\/column stuff.
 
-  | UnsafeMCDiagnostic Severity ResolvedDiagnosticReason (Maybe DiagnosticCode)
+  | UnsafeMCDiagnostic SrcSpan Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) SDoc JsonDoc
     -- ^ Diagnostics from the compiler. This constructor is very powerful as
-    -- it allows the construction of a 'MessageClass' with a completely
+    -- it allows the construction of a 'Message' with a completely
     -- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such,
     -- users are encouraged to use higher level primitives
     -- instead. Use this constructor directly only if you need to construct
@@ -508,8 +508,8 @@ data MessageClass
     -- should always have a 'DiagnosticCode'. See Note [Diagnostic codes].
 
 {-# COMPLETE MCOutput, MCFatal, MCInteractive, MCDump, MCInfo, MCDiagnostic #-}
-pattern MCDiagnostic :: Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> MessageClass
-pattern MCDiagnostic severity reason code <- UnsafeMCDiagnostic severity reason code
+pattern MCDiagnostic :: SrcSpan -> Severity -> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> Message
+pattern MCDiagnostic span severity reason code <- UnsafeMCDiagnostic span severity reason code _diagnostic _json
 
 {-
 Note [Suppressing Messages]
@@ -538,9 +538,6 @@ the "SevIgnore one" for a number of reasons:
 
 
 -- | Used to describe warnings and errors

---   o The message has a file\/line\/column heading,
---     plus "warning:" or "error:",
---     added by mkLocMessage
 --   o With 'SevIgnore' the message is suppressed
 --   o Output is intended for end users
 data Severity
@@ -563,15 +560,6 @@ instance ToJson Severity where
   json SevWarning = JSString "Warning"
   json SevError = JSString "Error"
 
-instance ToJson MessageClass where
-  json MCOutput = JSString "MCOutput"
-  json MCFatal  = JSString "MCFatal"
-  json MCInteractive = JSString "MCInteractive"
-  json MCDump = JSString "MCDump"
-  json MCInfo = JSString "MCInfo"
-  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))
 
@@ -646,35 +634,14 @@ showMsgEnvelope err =
 pprMessageBag :: Bag SDoc -> SDoc
 pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
 
-mkLocMessage
-  :: MessageClass                       -- ^ What kind of message?
-  -> SrcSpan                            -- ^ location
-  -> SDoc                               -- ^ message
-  -> SDoc
-mkLocMessage = mkLocMessageWarningGroups True
-
--- | Make an error message with location info, specifying whether to show
--- warning groups (if applicable).
-mkLocMessageWarningGroups
-  :: Bool                               -- ^ Print warning groups (if applicable)?
-  -> MessageClass                       -- ^ What kind of message?
-  -> SrcSpan                            -- ^ location
-  -> SDoc                               -- ^ message
-  -> SDoc
-mkLocMessageWarningGroups show_warn_groups msg_class locn msg
-  = case msg_class of
-    MCDiagnostic severity reason code -> formatDiagnostic show_warn_groups locn severity reason code msg
-    _ -> sdocOption sdocColScheme $ \col_scheme ->
-      let
-          msg_colour = getMessageClassColour msg_class col_scheme
-
-          msg_title = coloured msg_colour $
-            case msg_class of
-              MCFatal                     -> text "fatal"
-              _                           -> empty
-
+formatFatalLocMessage :: SrcSpan -> SDoc -> SDoc
+formatFatalLocMessage locn msg = sdocOption sdocColScheme $ \col_scheme ->
+      let msg_title = coloured (Col.sFatal col_scheme) $ text "fatal"
       in formatLocMessageWarningGroups locn msg_title empty empty msg
 
+formatLocMessage :: SrcSpan -> SDoc -> SDoc
+formatLocMessage span = formatLocMessageWarningGroups span empty empty empty
+
 formatDiagnostic
   :: Bool                               -- ^ Print warning groups?
   -> SrcSpan                            -- ^ location
@@ -784,13 +751,7 @@ formatLocMessageWarningGroups locn msg_title code_doc warning_flag_doc msg
                    code_doc <+> warning_flag_doc
 
       in coloured (Col.sMessage col_scheme)
-                  (hang (coloured (Col.sHeader col_scheme) header) 4
-                        msg)
-
-getMessageClassColour :: MessageClass -> Col.Scheme -> Col.PprColour
-getMessageClassColour (MCDiagnostic severity _reason _code)   = getSeverityColour severity
-getMessageClassColour MCFatal                                 = Col.sFatal
-getMessageClassColour _                                       = const mempty
+                  $ hang (coloured (Col.sHeader col_scheme) header) 4 msg
 
 getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour
 getSeverityColour severity = case severity of
@@ -798,9 +759,9 @@ getSeverityColour severity = case severity of
   SevWarning -> Col.sWarning
   SevIgnore -> const mempty
 
-getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc
+getCaretDiagnostic :: Severity -> SrcSpan -> IO SDoc
 getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty
-getCaretDiagnostic msg_class (RealSrcSpan span _) =
+getCaretDiagnostic severity (RealSrcSpan span _) =
   caretDiagnostic <$> getSrcLine (srcSpanFile span) row
   where
     getSrcLine fn i =
@@ -833,7 +794,7 @@ getCaretDiagnostic msg_class (RealSrcSpan span _) =
     caretDiagnostic Nothing = empty
     caretDiagnostic (Just srcLineWithNewline) =
       sdocOption sdocColScheme$ \col_scheme ->
-      let sevColour = getMessageClassColour msg_class col_scheme
+      let sevColour = getSeverityColour severity col_scheme
           marginColour = Col.sMargin col_scheme
       in
       coloured marginColour (text marginSpace) <>


=====================================
compiler/GHC/Utils/Error.hs
=====================================
@@ -14,7 +14,7 @@ module GHC.Utils.Error (
         -- * Messages
         Diagnostic(..),
         MsgEnvelope(..),
-        MessageClass(..),
+        Message(..),
         SDoc,
         DecoratedSDoc(unDecorated),
         Messages,
@@ -28,7 +28,7 @@ module GHC.Utils.Error (
 
         -- ** Construction
         DiagOpts (..), emptyDiagOpts, diag_wopt, diag_fatal_wopt,
-        emptyMessages, mkDecorated, mkLocMessage,
+        emptyMessages, mkDecorated,
         mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope,
         mkErrorMsgEnvelope,
         mkLintWarning, diagReasonSeverity,
@@ -282,9 +282,8 @@ unsafePprLocMsgEnvelope opts (MsgEnvelope { errMsgSpan      = s
                                , errMsgContext   = name_ppr_ctx
                                , errMsgReason    = reason })
   = withErrStyle name_ppr_ctx $
-      mkLocMessage
-        (UnsafeMCDiagnostic sev reason (diagnosticCode e))
-        s
+      formatDiagnostic True
+        s sev reason (diagnosticCode e)
         (formatBulleted $ diagnosticMessage opts e)
 
 sortMsgBag :: Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]
@@ -314,7 +313,7 @@ ghcExit logger val
 
 fatalErrorMsg :: Logger -> SDoc -> IO ()
 fatalErrorMsg logger msg =
-    logMsg logger MCFatal noSrcSpan $ withPprStyle defaultErrStyle msg
+    logMsg logger $ MCFatal (withPprStyle defaultErrStyle msg)
 
 compilationProgressMsg :: Logger -> SDoc -> IO ()
 compilationProgressMsg logger msg = do
@@ -475,11 +474,11 @@ printOutputForUser logger name_ppr_ctx msg
   = logOutput logger (withUserStyle name_ppr_ctx AllTheWay msg)
 
 logInfo :: Logger -> SDoc -> IO ()
-logInfo logger msg = logMsg logger MCInfo noSrcSpan msg
+logInfo logger = logMsg logger . MCInfo
 
 -- | Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'
 logOutput :: Logger -> SDoc -> IO ()
-logOutput logger msg = logMsg logger MCOutput noSrcSpan msg
+logOutput logger = logMsg logger . MCOutput
 
 
 prettyPrintGhcErrors :: ExceptionMonad m => Logger -> m a -> m a


=====================================
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,15 +52,11 @@ module GHC.Utils.Logger
     , putLogMsg
     , defaultLogAction
     , defaultLogActionWithHandles
-    , defaultLogJsonAction
     , defaultLogActionHPrintDoc
     , defaultLogActionHPutStrDoc
     , logMsg
-    , logJsonMsg
     , logDumpMsg
 
-    , decorateDiagnostic
-
     -- * Dumping
     , defaultDumpAction
     , putDumpFile
@@ -85,16 +78,14 @@ where
 import GHC.Prelude
 import GHC.Driver.Flags
 import GHC.Types.Error
-import GHC.Types.SrcLoc
 
 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
-import GHC.Data.FastString
 
 import System.Directory
 import System.FilePath  ( takeDirectory, () )
@@ -182,16 +173,9 @@ setLogFlags logger flags = logger { logFlags = flags }
 ---------------------------------------------------------------
 
 type LogAction = LogFlags
-              -> MessageClass
-              -> SrcSpan
-              -> SDoc
+              -> Message
               -> IO ()
 
-type LogJsonAction = LogFlags
-                   -> MessageClass
-                   -> JsonDoc
-                   -> IO ()
-
 type DumpAction = LogFlags
                -> PprStyle
                -> DumpFlag
@@ -229,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
 
@@ -267,7 +248,6 @@ initLogger = do
     dumps <- newMVar Map.empty
     return $ Logger
         { log_hook        = []
-        , json_log_hook   = []
         , dump_hook       = []
         , trace_hook      = []
         , generated_dumps = dumps
@@ -279,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 =
@@ -307,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 }
@@ -344,8 +311,8 @@ makeThreadSafe logger = do
         with_lock :: forall a. IO a -> IO a
         with_lock act = withMVar lock (const act)
 
-        log action logflags msg_class loc doc =
-            with_lock (action logflags msg_class loc doc)
+        log action logflags message =
+            with_lock (action logflags message)
 
         dmp action logflags sty opts str fmt doc =
             with_lock (action logflags sty opts str fmt doc)
@@ -359,49 +326,6 @@ makeThreadSafe logger = do
            $ pushTraceHook trc
            $ 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
-jsonLogActionWithHandle :: Handle {-^ Standard out -} -> LogAction
-jsonLogActionWithHandle _ _ (MCDiagnostic SevIgnore _ _) _ _ = return () -- suppress the message
-jsonLogActionWithHandle out logflags msg_class srcSpan msg
-  =
-    defaultLogActionHPutStrDoc logflags True out
-      (withPprStyle PprCode (doc $$ text ""))
-    where
-      str = renderWithContext (log_default_user_context logflags) msg
-      doc = renderJSON $
-              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
-
 -- | The default 'LogAction' prints to 'stdout' and 'stderr'.
 --
 -- To replicate the default log action behaviour with different @out@ and @err@
@@ -412,72 +336,24 @@ defaultLogAction = defaultLogActionWithHandles stdout stderr
 -- | The default 'LogAction' parametrized over the standard output and standard error handles.
 -- Allows clients to replicate the log message formatting of GHC with custom handles.
 defaultLogActionWithHandles :: Handle {-^ Handle for standard output -} -> Handle {-^ Handle for standard errors -} -> LogAction
-defaultLogActionWithHandles out err logflags msg_class srcSpan msg
-  | log_dopt Opt_D_dump_json logflags = jsonLogActionWithHandle out logflags msg_class srcSpan msg
-  | otherwise = 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 -> decorateDiagnostic logflags msg_class srcSpan msg >>= printErrs
+defaultLogActionWithHandles out err logflags message
+  = case message of
+      MCOutput msg -> printOut msg
+      MCDump msg -> printOut (msg $$ blankLine)
+      MCInteractive msg -> putStrSDoc msg
+      MCInfo msg -> printErrs msg
+      MCFatal 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
       putStrSDoc = defaultLogActionHPutStrDoc logflags False out
 
--- 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 the message in `printMessages`.
---
--- 2. GHC uses two different code paths for JSON and non-JSON diagnostics.  For
---    that reason we can not 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`)
---
--- This story is tracked by #24113.
-decorateDiagnostic :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc
-decorateDiagnostic logflags msg_class srcSpan msg = addCaret
-    where
-      -- Pretty print the warning flag, if any (#10752)
-      message :: SDoc
-      message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg
-
-      addCaret :: IO SDoc
-      addCaret = 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 ()
 defaultLogActionHPrintDoc logflags asciiSpace h d
@@ -491,28 +367,6 @@ defaultLogActionHPutStrDoc logflags asciiSpace h d
   -- calls to this log-action can output all on the same line
   = printSDoc (log_default_user_context logflags) (Pretty.PageMode asciiSpace) h d
 
---
--- Note [JSON Error Messages]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- When the user requests the compiler output to be dumped as json
--- we used to collect them all in an IORef and then print them at the end.
--- This doesn't work very well with GHCi. (See #14078) So instead we now
--- use the simpler method of just outputting a JSON document inplace to
--- stdout.
---
--- Before the compiler calls log_action, it has already turned the `ErrMsg`
--- into a formatted message. This means that we lose some possible
--- 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. This cleanup is tracked in #24113.
-
 -- | Default action for 'dumpAction' hook
 defaultDumpAction :: DumpCache -> LogAction -> DumpAction
 defaultDumpAction dumps log_action logflags sty flag title _fmt doc =
@@ -545,10 +399,10 @@ dumpSDocWithStyle dumps log_action sty logflags flag hdr doc =
 
     -- write the dump to stdout
     writeDump Nothing = do
-        let (doc', msg_class)
-              | null hdr  = (doc, MCOutput)
-              | otherwise = (mkDumpDoc hdr doc, MCDump)
-        log_action logflags msg_class noSrcSpan (withPprStyle sty doc')
+        let message
+              | null hdr  = MCOutput (withPprStyle sty doc)
+              | otherwise = MCDump (withPprStyle sty $ mkDumpDoc hdr doc)
+        log_action logflags message
 
 
 -- | Run an action with the handle of a 'DumpFlag' if we are outputting to a
@@ -638,11 +492,8 @@ defaultTraceAction logflags title doc x =
 
 
 -- | Log something
-logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
-logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg
-
-logJsonMsg :: Logger -> MessageClass -> JsonDoc -> IO ()
-logJsonMsg logger mc = putJsonLogMsg logger (logFlags logger) mc
+logMsg :: Logger -> Message -> IO ()
+logMsg logger = putLogMsg logger (logFlags logger)
 
 -- | Dump something
 logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
@@ -654,7 +505,7 @@ logTraceMsg logger hdr doc a = putTraceMsg logger (logFlags logger) hdr doc a
 
 -- | Log a dump message (not a dump file)
 logDumpMsg :: Logger -> String -> SDoc -> IO ()
-logDumpMsg logger hdr doc = logMsg logger MCDump noSrcSpan
+logDumpMsg logger hdr doc = logMsg logger $ MCDump
   (withPprStyle defaultDumpStyle
   (mkDumpDoc hdr doc))
 


=====================================
docs/users_guide/debugging.rst
=====================================
@@ -55,13 +55,6 @@ Dumping out compiler intermediate structures
     ``Main.p.dump-simpl`` and ``Main.dump-simpl`` instead of overwriting the
     output of one way with the output of another.
 
-.. ghc-flag:: -ddump-json
-    :shortdesc: *(deprecated)* Use :ghc-flag:`-fdiagnostics-as-json` instead
-    :type: dynamic
-
-    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
     :type: dynamic


=====================================
ghc/GHCi/UI.hs
=====================================
@@ -498,8 +498,6 @@ interactiveUI config srcs maybe_exprs = do
 
    installInteractiveHomeUnits
 
-   -- Update the LogAction. Ensure we don't override the user's log action lest
-   -- we break -ddump-json (#14078)
    lastErrLocationsRef <- liftIO $ newIORef []
    pushLogHookM (ghciLogAction lastErrLocationsRef)
 
@@ -835,10 +833,10 @@ resetLastErrorLocations = do
 
 ghciLogAction :: IORef [(FastString, Int)] -> LogAction -> LogAction
 ghciLogAction lastErrLocations old_log_action
-              dflags msg_class srcSpan msg = do
-    old_log_action dflags msg_class srcSpan msg
-    case msg_class of
-        MCDiagnostic SevError _reason _code -> case srcSpan of
+              dflags msg = do
+    old_log_action dflags msg
+    case msg of
+        MCDiagnostic srcSpan SevError _reason _code -> case srcSpan of
             RealSrcSpan rsp _ -> modifyIORef lastErrLocations
                 (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])
             _ -> return ()


=====================================
testsuite/tests/driver/T16167.stderr
=====================================
@@ -1 +1,2 @@
+{"version":"1.2","ghcVersion":"ghc-9.15.20250819","span":{"file":"T16167.hs","start":{"line":1,"column":8},"end":{"line":1,"column":9}},"severity":"Error","code":58481,"rendered":"T16167.hs:1:8: error: [GHC-58481] parse error on input \u2018f\u2019\n","message":["parse error on input \u2018f\u2019"],"hints":[]}
 *** Exception: ExitFailure 1


=====================================
testsuite/tests/driver/T16167.stdout deleted
=====================================
@@ -1,2 +0,0 @@
-{"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"}


=====================================
testsuite/tests/driver/all.T
=====================================
@@ -274,12 +274,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_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 -Wx-partial'])
-test('json2', normalise_version('ghc-internal', 'base','ghc-prim'), compile, ['-ddump-types -ddump-json -Wno-unsupported-llvm-version'])
+test('json2', normalise_version('ghc-internal', 'base','ghc-prim'), compile, ['-ddump-types -fdiagnostics-as-json -Wno-unsupported-llvm-version'])
 test('T16167', [normalise_version('ghc'),req_interp,exit_code(1)], run_command,
-     ['{compiler} -x hs -e ":set prog T16167.hs" -ddump-json T16167.hs'])
+     ['{compiler} -x hs -e ":set prog T16167.hs" -fdiagnostics-as-json T16167.hs'])
 test('T13604', [], makefile_test, [])
 test('T13604a',
   [ js_broken(22261) # require HPC support


=====================================
testsuite/tests/driver/json2.stderr
=====================================
@@ -1,2 +1,4 @@
-{"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: [(normal, base-4.21.0.0)]","messageClass":"MCOutput"}
+TYPE SIGNATURES
+  foo :: forall a. a -> a
+Dependent modules: []
+Dependent packages: [(normal, base-4.21.0.0)]


=====================================
testsuite/tests/driver/json_dump.hs deleted
=====================================
@@ -1,6 +0,0 @@
-module Foo where
-
-import Data.List
-
-id1 :: a -> a
-id1 = 5


=====================================
testsuite/tests/driver/json_dump.stderr deleted
=====================================
@@ -1,2 +0,0 @@
-{"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"}


=====================================
testsuite/tests/ghc-api/T7478/T7478.hs
=====================================
@@ -24,11 +24,11 @@ compileInGhc targets handlerOutput = do
     flags0 <- getSessionDynFlags
     let flags = flags0 {verbosity = 1 }
     setSessionDynFlags flags
-    let collectSrcError handlerOutput _flags MCOutput _srcspan msg
+    let collectSrcError _flags (MCOutput msg)
           = handlerOutput $ GHC.showSDocForUser flags emptyUnitState alwaysQualify msg
-        collectSrcError _ _ _ _ _
+        collectSrcError _ _
           = return ()
-    pushLogHookM (const (collectSrcError handlerOutput))
+    pushLogHookM (const collectSrcError)
     -- Set up targets.
     oldTargets <- getTargets
     let oldFiles = map fileFromTarget oldTargets


=====================================
testsuite/tests/plugins/hooks-plugin/Hooks/LogPlugin.hs
=====================================
@@ -19,6 +19,6 @@ hooksP opts hsc_env = do
   return hsc_env'
 
 logHook :: LogAction -> LogAction
-logHook action logFlags messageClass srcSpan msgDoc = do
+logHook action logFlags message = do
   putStrLn "Log hook called"
-  action logFlags messageClass srcSpan msgDoc
+  action logFlags message



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0465d8c6c112b8c0dbfae85a7af30e0...

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0465d8c6c112b8c0dbfae85a7af30e0...
You're receiving this email because of your account on gitlab.haskell.org.

    

Simon Hengel (＠sol)

tags

participants (1)