Simon Hengel pushed to branch wip/sol/remove-ddump-json at Glasgow Haskell Compiler / GHC Commits: 08b2d89a by Simon Hengel at 2025-07-28T14:58:41+07:00 Rename MCDiagnostic to UnsafeMCDiagnostic - - - - - acb24033 by Simon Hengel at 2025-07-28T14:59:11+07:00 Remove -ddump-json (fixes #24113) - - - - - 22 changed files: - compiler/GHC/Core/Lint.hs - compiler/GHC/Driver/Errors.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/Stg/Lint.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Types/SourceError.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 Changes: ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -3418,7 +3418,7 @@ addMsg show_context env msgs msg [] -> noSrcSpan (s:_) -> s !diag_opts = le_diagOpts env - mk_msg msg = mkLocMessage (mkMCDiagnostic diag_opts WarningWithoutFlag Nothing) msg_span + mk_msg msg = mkLocMessage (unsafeMCDiagnostic diag_opts WarningWithoutFlag Nothing) msg_span (msg $$ context) addLoc :: LintLocInfo -> LintM a -> LintM a ===================================== compiler/GHC/Driver/Errors.hs ===================================== @@ -67,7 +67,7 @@ printMessage logger msg_opts opts message doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic) messageClass :: MessageClass - messageClass = MCDiagnostic severity (errMsgReason message) (diagnosticCode diagnostic) + messageClass = UnsafeMCDiagnostic severity (errMsgReason message) (diagnosticCode diagnostic) style :: PprStyle style = mkErrStyle (errMsgContext message) ===================================== 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 ===================================== @@ -1829,7 +1829,7 @@ markUnsafeInfer tcg_env whyUnsafe = do , nest 4 $ (vcat $ badFlags df) $+$ -- MP: Using defaultDiagnosticOpts here is not right but it's also not right to handle these -- unsafety error messages in an unstructured manner. - (vcat $ pprMsgEnvelopeBagWithLoc (defaultDiagnosticOpts @e) (getMessages whyUnsafe)) $+$ + (vcat $ unsafePprMsgEnvelopeBagWithLoc (defaultDiagnosticOpts @e) (getMessages whyUnsafe)) $+$ (vcat $ badInsts $ tcg_insts tcg_env) ] badFlags df = concatMap (badFlag df) unsafeFlagsForInfer ===================================== compiler/GHC/Driver/Pipeline.hs ===================================== @@ -163,7 +163,7 @@ preprocess hsc_env input_fn mb_input_buf mb_phase = to_driver_messages msgs = case traverse to_driver_message msgs of Nothing -> pprPanic "non-driver message in preprocess" -- MP: Default config is fine here as it's just in a panic. - (vcat $ pprMsgEnvelopeBagWithLoc (defaultDiagnosticOpts @GhcMessage) (getMessages msgs)) + (vcat $ unsafePprMsgEnvelopeBagWithLoc (defaultDiagnosticOpts @GhcMessage) (getMessages msgs)) Just msgs' -> msgs' to_driver_message = \case ===================================== 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/HsToCore/Monad.hs ===================================== @@ -376,7 +376,7 @@ initTcDsForSolver thing_inside thing_inside ; case mb_ret of Just ret -> pure ret - Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) } + Nothing -> pprPanic "initTcDsForSolver" (vcat $ unsafePprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) } mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv -> PromotionTickContext ===================================== compiler/GHC/Stg/Lint.hs ===================================== @@ -540,7 +540,7 @@ addErr diag_opts errs_so_far msg locs = errs_so_far `snocBag` mk_msg locs where mk_msg (loc:_) = let (l,hdr) = dumpLoc loc - in mkLocMessage (Err.mkMCDiagnostic diag_opts WarningWithoutFlag Nothing) + in mkLocMessage (Err.unsafeMCDiagnostic diag_opts WarningWithoutFlag Nothing) l (hdr $$ msg) mk_msg [] = msg ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -65,7 +65,7 @@ import GHC.Core.InstEnv import GHC.Core.TyCon import GHC.Core.DataCon -import GHC.Utils.Error (diagReasonSeverity, pprLocMsgEnvelope ) +import GHC.Utils.Error (diagReasonSeverity, unsafePprLocMsgEnvelope ) import GHC.Utils.Misc import GHC.Utils.Outputable as O import GHC.Utils.Panic @@ -1294,7 +1294,7 @@ mkErrorTerm ct_loc ty ctxt msg supp hints hints -- This will be reported at runtime, so we always want "error:" in the report, never "warning:" ; dflags <- getDynFlags - ; let err_msg = pprLocMsgEnvelope (initTcMessageOpts dflags) msg + ; let err_msg = unsafePprLocMsgEnvelope (initTcMessageOpts dflags) msg err_str = showSDoc dflags $ err_msg $$ text "(deferred type error)" ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -1146,7 +1146,7 @@ reportDiagnostics = mapM_ reportDiagnostic reportDiagnostic :: MsgEnvelope TcRnMessage -> TcRn () reportDiagnostic msg - = do { traceTc "Adding diagnostic:" (pprLocMsgEnvelopeDefault msg) ; + = do { traceTc "Adding diagnostic:" (unsafePprLocMsgEnvelopeDefault msg) ; errs_var <- getErrsVar ; msgs <- readTcRef errs_var ; writeTcRef errs_var (msg `addMessage` msgs) } ===================================== compiler/GHC/Types/Error.hs ===================================== @@ -26,7 +26,7 @@ module GHC.Types.Error -- * Classifying Messages - , MessageClass (..) + , MessageClass (MCDiagnostic, ..) , Severity (..) , Diagnostic (..) , UnknownDiagnostic (..) @@ -491,11 +491,11 @@ data MessageClass -- ^ Log messages intended for end users. -- No file\/line\/column stuff. - | MCDiagnostic Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) + | UnsafeMCDiagnostic Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) -- ^ Diagnostics from the compiler. This constructor is very powerful as -- it allows the construction of a 'MessageClass' with a completely -- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such, - -- users are encouraged to use the 'mkMCDiagnostic' smart constructor + -- users are encouraged to use the 'unsafeMCDiagnostic' smart constructor -- instead. Use this constructor directly only if you need to construct -- and manipulate diagnostic messages directly, for example inside -- 'GHC.Utils.Error'. In all the other circumstances, /especially/ when @@ -506,6 +506,10 @@ data MessageClass -- error-message type, then use Nothing. In the long run, this really -- 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 + {- Note [Suppressing Messages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Types/SourceError.hs ===================================== @@ -14,7 +14,7 @@ import GHC.Types.Error import GHC.Utils.Monad import GHC.Utils.Panic import GHC.Utils.Exception -import GHC.Utils.Error (pprMsgEnvelopeBagWithLocDefault) +import GHC.Utils.Error (unsafePprMsgEnvelopeBagWithLocDefault) import GHC.Utils.Outputable import GHC.Driver.Errors.Ppr () -- instance Diagnostic GhcMessage @@ -59,7 +59,7 @@ instance Show SourceError where show (SourceError msgs) = renderWithContext defaultSDocContext . vcat - . pprMsgEnvelopeBagWithLocDefault + . unsafePprMsgEnvelopeBagWithLocDefault . getMessages $ msgs ===================================== compiler/GHC/Utils/Error.hs ===================================== @@ -22,9 +22,8 @@ module GHC.Utils.Error ( errorsFound, isEmptyMessages, -- ** Formatting - pprMessageBag, pprMsgEnvelopeBagWithLoc, pprMsgEnvelopeBagWithLocDefault, - pprMessages, - pprLocMsgEnvelope, pprLocMsgEnvelopeDefault, + pprMessageBag, unsafePprMsgEnvelopeBagWithLoc, unsafePprMsgEnvelopeBagWithLocDefault, + unsafePprLocMsgEnvelope, unsafePprLocMsgEnvelopeDefault, formatBulleted, -- ** Construction @@ -32,7 +31,7 @@ module GHC.Utils.Error ( emptyMessages, mkDecorated, mkLocMessage, mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope, mkErrorMsgEnvelope, - mkMCDiagnostic, diagReasonSeverity, + unsafeMCDiagnostic, diagReasonSeverity, mkPlainError, mkPlainDiagnostic, @@ -162,8 +161,8 @@ diag_reason_severity opts reason = fmap ResolvedDiagnosticReason $ case reason o -- | Make a 'MessageClass' for a given 'DiagnosticReason', consulting the -- 'DiagOpts'. -mkMCDiagnostic :: DiagOpts -> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass -mkMCDiagnostic opts reason code = MCDiagnostic sev reason' code +unsafeMCDiagnostic :: DiagOpts -> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass +unsafeMCDiagnostic opts reason code = UnsafeMCDiagnostic sev reason' code where (sev, reason') = diag_reason_severity opts reason @@ -267,29 +266,26 @@ formatBulleted (unDecorated -> docs) msgs ctx = filter (not . Outputable.isEmpty ctx) docs starred = (bullet<+>) -pprMessages :: Diagnostic e => DiagnosticOpts e -> Messages e -> SDoc -pprMessages e = vcat . pprMsgEnvelopeBagWithLoc e . getMessages - -pprMsgEnvelopeBagWithLoc :: Diagnostic e => DiagnosticOpts e -> Bag (MsgEnvelope e) -> [SDoc] -pprMsgEnvelopeBagWithLoc e bag = [ pprLocMsgEnvelope e item | item <- sortMsgBag Nothing bag ] +unsafePprMsgEnvelopeBagWithLoc :: Diagnostic e => DiagnosticOpts e -> Bag (MsgEnvelope e) -> [SDoc] +unsafePprMsgEnvelopeBagWithLoc e bag = [ unsafePprLocMsgEnvelope e item | item <- sortMsgBag Nothing bag ] -- | Print the messages with the suitable default configuration, usually not what you want but sometimes you don't really -- care about what the configuration is (for example, if the message is in a panic). -pprMsgEnvelopeBagWithLocDefault :: forall e . Diagnostic e => Bag (MsgEnvelope e) -> [SDoc] -pprMsgEnvelopeBagWithLocDefault bag = [ pprLocMsgEnvelopeDefault item | item <- sortMsgBag Nothing bag ] +unsafePprMsgEnvelopeBagWithLocDefault :: forall e . Diagnostic e => Bag (MsgEnvelope e) -> [SDoc] +unsafePprMsgEnvelopeBagWithLocDefault bag = [ unsafePprLocMsgEnvelopeDefault item | item <- sortMsgBag Nothing bag ] -pprLocMsgEnvelopeDefault :: forall e . Diagnostic e => MsgEnvelope e -> SDoc -pprLocMsgEnvelopeDefault = pprLocMsgEnvelope (defaultDiagnosticOpts @e) +unsafePprLocMsgEnvelopeDefault :: forall e . Diagnostic e => MsgEnvelope e -> SDoc +unsafePprLocMsgEnvelopeDefault = unsafePprLocMsgEnvelope (defaultDiagnosticOpts @e) -pprLocMsgEnvelope :: Diagnostic e => DiagnosticOpts e -> MsgEnvelope e -> SDoc -pprLocMsgEnvelope opts (MsgEnvelope { errMsgSpan = s +unsafePprLocMsgEnvelope :: Diagnostic e => DiagnosticOpts e -> MsgEnvelope e -> SDoc +unsafePprLocMsgEnvelope opts (MsgEnvelope { errMsgSpan = s , errMsgDiagnostic = e , errMsgSeverity = sev , errMsgContext = name_ppr_ctx , errMsgReason = reason }) = withErrStyle name_ppr_ctx $ mkLocMessage - (MCDiagnostic sev reason (diagnosticCode e)) + (UnsafeMCDiagnostic sev reason (diagnosticCode e)) s (formatBulleted $ diagnosticMessage opts e) ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -94,7 +94,6 @@ import GHC.Utils.Panic import GHC.Data.EnumSet (EnumSet) import qualified GHC.Data.EnumSet as EnumSet -import GHC.Data.FastString import System.Directory import System.FilePath ( takeDirectory, (</>) ) @@ -359,7 +358,6 @@ makeThreadSafe logger = do $ pushTraceHook trc $ logger --- See Note [JSON Error Messages] defaultLogJsonAction :: LogJsonAction defaultLogJsonAction logflags msg_class jsdoc = case msg_class of @@ -376,32 +374,6 @@ defaultLogJsonAction logflags msg_class jsdoc = 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@ @@ -413,8 +385,7 @@ defaultLogAction = defaultLogActionWithHandles stdout stderr -- 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 + = case msg_class of MCOutput -> printOut msg MCDump -> printOut (msg $$ blankLine) MCInteractive -> putStrSDoc msg @@ -491,28 +462,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 = ===================================== 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) ===================================== testsuite/tests/driver/T16167.stderr ===================================== @@ -1 +1,2 @@ +{"version":"1.1","ghcVersion":"ghc-9.13.20250627","span":{"file":"T16167.hs","start":{"line":1,"column":8},"end":{"line":1,"column":9}},"severity":"Error","code":58481,"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"} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/74b8e7d5c6cf239488113a20b9a4c19... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/74b8e7d5c6cf239488113a20b9a4c19... You're receiving this email because of your account on gitlab.haskell.org.