Simon Hengel pushed to branch wip/sol/rename-mc-diagnostics at Glasgow Haskell Compiler / GHC Commits: 0484b827 by Simon Hengel at 2026-06-25T05:40:17+07:00 Rename `MCDiagnostic` to `UnsafeMCDiagnostic` `MCDiagnostic` is meant to be used for compiler diagnostics. Any code that creates `MCDiagnostic` directly, without going through `GHC.Driver.Errors.printMessage`, sidesteps `-fdiagnostics-as-json` (see e.g. !14616, !14475, !14492 !14548). To avoid this in the future, this change more narrowly controls who creates `MCDiagnostic` (see #24113). - - - - - 15 changed files: - compiler/GHC/Driver/Errors.hs - compiler/GHC/Driver/Main/Passes.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Error.hs - − compiler/GHC/Types/Error.hs-boot - compiler/GHC/Types/SourceError.hs - compiler/GHC/Utils/Error.hs - ghc/GHCi/UI/Exception.hs - utils/check-exact/Main.hs - utils/check-exact/Preprocess.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs Changes: ===================================== compiler/GHC/Driver/Errors.hs ===================================== @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-x-unsafe-diagnostics #-} module GHC.Driver.Errors ( reportError , reportDiagnostic @@ -66,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/Main/Passes.hs ===================================== @@ -2,6 +2,7 @@ {-# LANGUAGE MultiWayIf #-} {-# OPTIONS_GHC -fprof-auto-top #-} +{-# OPTIONS_GHC -Wno-x-unsafe-diagnostics #-} ------------------------------------------------------------------------------- -- | Aspects of GHC.Driver.Main dealing with running particular passes. @@ -1400,9 +1401,10 @@ markUnsafeInfer tcg_env whyUnsafe = do whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!" , text "Reason:" , 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)) $+$ + -- `unsafePprMessages` uses `defaultDiagnosticOpts`. + -- That is not right, but it's also not right to handle + -- these unsafety error messages in an unstructured manner. + (vcat $ unsafePprMessages (getMessages whyUnsafe)) $+$ (vcat $ badInsts $ tcg_insts tcg_env) ] badFlags df = concatMap (badFlag df) unsafeFlagsForInfer ===================================== compiler/GHC/Driver/Pipeline.hs ===================================== @@ -101,7 +101,7 @@ import GHC.Iface.Recomp import GHC.Runtime.Loader ( initializePlugins ) import GHC.Types.Basic ( SuccessFlag(..), ForeignSrcLang(..) ) -import GHC.Types.Error ( singleMessage, getMessages, mkSimpleUnknownDiagnostic, defaultDiagnosticOpts ) +import GHC.Types.Error ( singleMessage, getMessages, mkSimpleUnknownDiagnostic ) import GHC.Types.ForeignStubs ( ForeignStubs (NoStubs) ) import GHC.Types.Target import GHC.Types.SrcLoc @@ -169,9 +169,7 @@ preprocess hsc_env input_fn mb_input_buf mb_phase = to_driver_messages :: Messages GhcMessage -> Messages DriverMessage 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)) + Nothing -> panicMessage "non-driver message in preprocess" (getMessages msgs) Just msgs' -> msgs' to_driver_message = \case ===================================== compiler/GHC/HsToCore/Monad.hs ===================================== @@ -404,7 +404,7 @@ initTcDsForSolver thing_inside thing_inside ; case mb_ret of Just ret -> pure ret - Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) } + Nothing -> panicMessage "initTcDsForSolver" (getErrorMessages msgs) } mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv -> TcMPluginsRun ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -71,7 +71,7 @@ import GHC.Core.TyCo.FVs import GHC.Core.InstEnv import GHC.Core.TyCon -import GHC.Utils.Error (diagReasonSeverity, pprLocMsgEnvelope ) +import GHC.Utils.Error (diagReasonSeverity, deferredTypeErrorMessage ) import GHC.Utils.Misc import GHC.Utils.Outputable as O import GHC.Utils.Panic @@ -1389,9 +1389,8 @@ 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 - err_str = showSDoc dflags $ - err_msg $$ text "(deferred type error)" + ; let err_msg = deferredTypeErrorMessage (initTcMessageOpts dflags) msg + err_str = showSDoc dflags err_msg ; return $ evDelayedError ty err_str } ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -1432,8 +1432,7 @@ reportDiagnostics = mapM_ reportDiagnostic reportDiagnostic :: MsgEnvelope TcRnMessage -> TcRn () reportDiagnostic msg - = do { traceTc "Adding diagnostic:" (pprLocMsgEnvelopeDefault msg) ; - errs_var <- getErrsVar ; + = do { errs_var <- getErrsVar ; msgs <- readTcRef errs_var ; writeTcRef errs_var (msg `addMessage` msgs) } ===================================== compiler/GHC/Types/Error.hs ===================================== @@ -18,7 +18,7 @@ module GHC.Types.Error -- * Classifying Messages - , MessageClass (..) + , MessageClass (MCDiagnostic, ..) , Severity (..) , Diagnostic (..) , UnknownDiagnostic (..) @@ -482,7 +482,7 @@ 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, @@ -492,10 +492,19 @@ data MessageClass -- 'GHC.Utils.Error'. In all the other circumstances, /especially/ when -- emitting compiler diagnostics, use higher level primitives. -- + -- For deconstruction use `MCDiagnostic`. + -- -- The @Maybe 'DiagnosticCode'@ field carries a code (if available) for -- this diagnostic. If you are creating a message not tied to any -- error-message type, then use Nothing. In the long run, this really -- should always have a 'DiagnosticCode'. See Note [Diagnostic codes]. + -- +{-# WARNING in "x-unsafe-diagnostics" UnsafeMCDiagnostic + "This is an internal constructor. Use `MCDiagnostic` or `GHC.Driver.Errors.printMessages` instead." #-} + +{-# 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/Error.hs-boot deleted ===================================== @@ -1,24 +0,0 @@ -module GHC.Types.Error where - -import GHC.Prelude (Maybe, Bool, IO) -import GHC.Utils.Outputable (SDoc) -import GHC.Types.SrcLoc (SrcSpan) - -data MessageClass - = MCOutput - | MCFatal - | MCInteractive - | MCDump - | MCInfo - | MCDiagnostic Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) - -data Severity - = SevIgnore - | SevWarning - | SevError - -data DiagnosticCode -data ResolvedDiagnosticReason - -mkLocMessageWarningGroups :: Bool -> MessageClass -> SrcSpan -> SDoc -> SDoc -getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc ===================================== compiler/GHC/Types/SourceError.hs ===================================== @@ -16,8 +16,7 @@ import GHC.Types.Error import GHC.Utils.Monad import GHC.Utils.Panic import GHC.Utils.Exception -import GHC.Utils.Error (pprMsgEnvelopeBagWithLocDefault, DiagOpts, diag_ppr_ctx) -import GHC.Utils.Outputable +import GHC.Utils.Error (unsafeShow, DiagOpts) import GHC.Driver.Config.Diagnostic (initDiagOpts, initPrintConfig) import GHC.Driver.DynFlags (DynFlags, HasDynFlags (getDynFlags)) @@ -76,12 +75,7 @@ instance Show SourceError where -- We implement 'Show' because it's required by the 'Exception' instance, but diagnostics -- shouldn't be shown via the 'Show' typeclass, but rather rendered using the ppr functions. -- This also explains why there is no 'Show' instance for a 'MsgEnvelope'. - show (SourceError (SEC diag_opts _) msgs) = - renderWithContext (diag_ppr_ctx diag_opts) - . vcat - . pprMsgEnvelopeBagWithLocDefault - . getMessages - $ msgs + show (SourceError _ msgs) = unsafeShow msgs instance Exception SourceError ===================================== compiler/GHC/Utils/Error.hs ===================================== @@ -1,5 +1,7 @@ {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-x-unsafe-diagnostics #-} + {- (c) The AQUA Project, Glasgow University, 1994-1998 @@ -22,10 +24,9 @@ module GHC.Utils.Error ( errorsFound, isEmptyMessages, -- ** Formatting - pprMessageBag, pprMsgEnvelopeBagWithLoc, pprMsgEnvelopeBagWithLocDefault, - pprMessages, - pprLocMsgEnvelope, pprLocMsgEnvelopeDefault, - formatBulleted, + pprMessageBag, formatBulleted, + deferredTypeErrorMessage, + panicMessage, unsafeShow, unsafePprMessages, -- ** Construction DiagOpts (..), emptyDiagOpts, diag_wopt, diag_fatal_wopt, @@ -265,29 +266,33 @@ 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 +deferredTypeErrorMessage :: Diagnostic e => DiagnosticOpts e -> MsgEnvelope e -> SDoc +deferredTypeErrorMessage opts msg = unsafePprMessage opts msg $$ text "(deferred type error)" -pprMsgEnvelopeBagWithLoc :: Diagnostic e => DiagnosticOpts e -> Bag (MsgEnvelope e) -> [SDoc] -pprMsgEnvelopeBagWithLoc e bag = [ pprLocMsgEnvelope e item | item <- sortMsgBag Nothing bag ] +panicMessage :: Diagnostic e => String -> Bag (MsgEnvelope e) -> a +panicMessage name msgs = pprPanic name (vcat $ unsafePprMessages msgs) --- | 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 ] +unsafeShow :: Diagnostic e => Messages e -> String +unsafeShow = + renderWithContext defaultSDocContext + . vcat + . unsafePprMessages + . getMessages -pprLocMsgEnvelopeDefault :: forall e . Diagnostic e => MsgEnvelope e -> SDoc -pprLocMsgEnvelopeDefault = pprLocMsgEnvelope (defaultDiagnosticOpts @e) +{-# WARNING in "x-unsafe-diagnostics" unsafePprMessages + "This function sidesteps @-fdiagnostics-as-json@! Use `GHC.Driver.Errors.printMessages` instead." #-} +unsafePprMessages :: forall e . Diagnostic e => Bag (MsgEnvelope e) -> [SDoc] +unsafePprMessages = map (unsafePprMessage (defaultDiagnosticOpts @e)) . sortMsgBag Nothing -pprLocMsgEnvelope :: Diagnostic e => DiagnosticOpts e -> MsgEnvelope e -> SDoc -pprLocMsgEnvelope opts (MsgEnvelope { errMsgSpan = s +unsafePprMessage :: Diagnostic e => DiagnosticOpts e -> MsgEnvelope e -> SDoc +unsafePprMessage 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) ===================================== ghc/GHCi/UI/Exception.hs ===================================== @@ -56,12 +56,7 @@ instance Show GhciCommandError where -- We implement 'Show' because it's required by the 'Exception' instance, but diagnostics -- shouldn't be shown via the 'Show' typeclass, but rather rendered using the ppr functions. -- This also explains why there is no 'Show' instance for a 'MsgEnvelope'. - show (GhciCommandError msgs) = - renderWithContext defaultSDocContext - . vcat - . pprMsgEnvelopeBagWithLocDefault - . getMessages - $ msgs + show (GhciCommandError msgs) = unsafeShow msgs -- | Perform the given action and call the exception handler if the action -- throws a 'GhciCommandError'. See 'GhciCommandError' for more information. ===================================== utils/check-exact/Main.hs ===================================== @@ -368,19 +368,11 @@ parseOneFile :: FilePath -> FilePath -> IO (ParsedSource, [Located Token]) parseOneFile libdir fileName = do res <- parseModuleEpAnnsWithCpp libdir defaultCppOptions fileName case res of - Left m -> error (showErrorMessages m) + Left m -> error (unsafeShow m) Right (injectedComments, _dflags, pmod) -> do let !pmodWithComments = insertCppComments pmod injectedComments return (pmodWithComments, []) -showErrorMessages :: Messages GhcMessage -> String -showErrorMessages msgs = - renderWithContext defaultSDocContext - $ vcat - $ pprMsgEnvelopeBagWithLocDefault - $ getMessages - $ msgs - -- --------------------------------------------------------------------- exactprintWithChange :: FilePath -> Changer -> ParsedSource -> IO (String, ParsedSource) ===================================== utils/check-exact/Preprocess.hs ===================================== @@ -216,20 +216,12 @@ getPreprocessedSrcDirectPrim cppOptions src_fn = do new_env = hsc_env { GHC.hsc_dflags = injectCppOptions cppOptions dfs } r <- GHC.liftIO $ GHC.preprocess new_env src_fn Nothing (Just (GHC.Cpp GHC.HsSrcFile)) case r of - Left err -> error $ showErrorMessages err + Left err -> error $ GHC.unsafeShow err Right (dflags', hspp_fn) -> do buf <- GHC.liftIO $ GHC.hGetStringBuffer hspp_fn txt <- GHC.liftIO $ readFileGhc hspp_fn return (txt, buf, dflags') -showErrorMessages :: GHC.Messages GHC.DriverMessage -> String -showErrorMessages msgs = - GHC.renderWithContext GHC.defaultSDocContext - $ GHC.vcat - $ GHC.pprMsgEnvelopeBagWithLocDefault - $ GHC.getMessages - $ msgs - injectCppOptions :: CppOptions -> GHC.DynFlags -> GHC.DynFlags injectCppOptions CppOptions{..} dflags = folded_opt where ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker.hs ===================================== @@ -97,7 +97,7 @@ ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = do mast | M.size asts == 1 = snd <$> M.lookupMin asts | otherwise = M.lookup (HiePath (mkFastString file)) asts - tokens' = parse parserOpts sDocContext file rawSrc + tokens' = parse parserOpts file rawSrc ast = fromMaybe (emptyHieAst fileFs) mast fullAst = recoverFullIfaceTypes sDocContext types ast ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs ===================================== @@ -9,7 +9,6 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import qualified Data.ByteString as BS import Data.List (isPrefixOf, isSuffixOf) -import GHC.Data.Bag (bagToList) import GHC.Data.FastString (mkFastString) import GHC.Data.StringBuffer (StringBuffer, atEnd) import GHC.Parser.Errors.Ppr () @@ -26,10 +25,7 @@ import GHC.Parser.Lexer as Lexer import qualified GHC.Types.Error as E import GHC.Types.SourceText import GHC.Types.SrcLoc -import GHC.Utils.Error (pprLocMsgEnvelopeDefault) -import GHC.Utils.Outputable (SDocContext, text, ($$)) -import qualified GHC.Utils.Outputable as Outputable -import GHC.Utils.Panic (panic) +import GHC.Utils.Error (panicMessage) import Haddock.Backends.Hyperlinker.Types as T import Haddock.GhcUtils @@ -40,19 +36,14 @@ import Haddock.GhcUtils -- whitespace, and CPP). parse :: ParserOpts - -> SDocContext -> FilePath -- ^ Path to the source of this module -> BS.ByteString -- ^ Raw UTF-8 encoded source of this module -> [T.Token] -parse parserOpts sDocContext fpath bs = case unP (go False []) initState of +parse parserOpts fpath bs = case unP (go False []) initState of POk _ toks -> reverse toks - PFailed pst -> - let err : _ = bagToList (E.getMessages $ getPsErrorMessages pst) - in panic $ - Outputable.renderWithContext sDocContext $ - text "Hyperlinker parse error:" $$ pprLocMsgEnvelopeDefault err + PFailed pst -> panicMessage "Hyperlinker parse error:" (E.getMessages $ getPsErrorMessages pst) where initState = initParserState parserOpts buf start buf = stringBufferFromByteString bs View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0484b827f0eb91b11930533351a40bf0... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0484b827f0eb91b11930533351a40bf0... You're receiving this email because of your account on gitlab.haskell.org.