Simon Hengel pushed to branch wip/sol/rename-mc-diagnostics at Glasgow Haskell Compiler / GHC Commits: 1a615970 by Simon Hengel at 2026-06-25T12:56:30+07:00 Rename `MCDiagnostic` to `InternalMCDiagnostic` `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-InternalMCDiagnostic #-} 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 = InternalMCDiagnostic 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 -Wwarn=x-internalPprMessages #-} ------------------------------------------------------------------------------- -- | Aspects of GHC.Driver.Main dealing with running particular passes. @@ -1401,9 +1402,15 @@ 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)) $+$ + + -- FIXME: `GHC.Utils.Error.internalPprMessages` is an + -- internal function! + -- + -- Use `GHC.Driver.Errors.printMessages` to report the + -- diagnostics here and remove `internalPprMessages` + -- from the export list of "GHC.Utils.Error". + (vcat $ internalPprMessages (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 @@ -1395,9 +1395,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 ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-x-internalDebugPpr #-} {- (c) The University of Glasgow 2006 @@ -1432,7 +1433,7 @@ reportDiagnostics = mapM_ reportDiagnostic reportDiagnostic :: MsgEnvelope TcRnMessage -> TcRn () reportDiagnostic msg - = do { traceTc "Adding diagnostic:" (pprLocMsgEnvelopeDefault msg) ; + = do { traceTc "Adding diagnostic:" (internalDebugPpr msg) ; 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) + | InternalMCDiagnostic 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-InternalMCDiagnostic" InternalMCDiagnostic + "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 <- InternalMCDiagnostic 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 ===================================== @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-x-internalDebugShow #-} -- | Source errors module GHC.Types.SourceError ( SourceError (..) @@ -16,8 +17,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 (internalDebugShow, DiagOpts) import GHC.Driver.Config.Diagnostic (initDiagOpts, initPrintConfig) import GHC.Driver.DynFlags (DynFlags, HasDynFlags (getDynFlags)) @@ -73,15 +73,12 @@ initSourceErrorContext dflags = in SEC diag_opts print_config 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. + -- We implement 'Show' because it's required by the 'Exception' instance, but + -- diagnostics must not be shown via 'Show', but instead reported via + -- `GHC.Driver.Errors.printMessages`. + -- -- 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) = internalDebugShow msgs instance Exception SourceError ===================================== compiler/GHC/Utils/Error.hs ===================================== @@ -1,5 +1,7 @@ {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-x-InternalMCDiagnostic #-} + {- (c) The AQUA Project, Glasgow University, 1994-1998 @@ -22,10 +24,11 @@ module GHC.Utils.Error ( errorsFound, isEmptyMessages, -- ** Formatting - pprMessageBag, pprMsgEnvelopeBagWithLoc, pprMsgEnvelopeBagWithLocDefault, - pprMessages, - pprLocMsgEnvelope, pprLocMsgEnvelopeDefault, - formatBulleted, + pprMessageBag, formatBulleted, + deferredTypeErrorMessage, + panicMessage, internalDebugShow, internalDebugPpr, + + internalPprMessages, -- FIXME: remove this export -- ** Construction DiagOpts (..), emptyDiagOpts, diag_wopt, diag_fatal_wopt, @@ -265,29 +268,40 @@ 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 ] - --- | 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 ] - -pprLocMsgEnvelopeDefault :: forall e . Diagnostic e => MsgEnvelope e -> SDoc -pprLocMsgEnvelopeDefault = pprLocMsgEnvelope (defaultDiagnosticOpts @e) - -pprLocMsgEnvelope :: Diagnostic e => DiagnosticOpts e -> MsgEnvelope e -> SDoc -pprLocMsgEnvelope opts (MsgEnvelope { errMsgSpan = s +deferredTypeErrorMessage :: Diagnostic e => DiagnosticOpts e -> MsgEnvelope e -> SDoc +deferredTypeErrorMessage opts msg = internalPprMessage opts msg $$ text "(deferred type error)" + +panicMessage :: Diagnostic e => String -> Bag (MsgEnvelope e) -> a +panicMessage name msgs = pprPanic name (vcat $ internalPprMessages msgs) + +{-# WARNING in "x-internalDebugShow" internalDebugShow + "Don't use this function for reporting diagnostics! Use `GHC.Driver.Errors.printMessages` instead." #-} +internalDebugShow :: Diagnostic e => Messages e -> String +internalDebugShow = + renderWithContext defaultSDocContext + . vcat + . internalPprMessages + . getMessages + +{-# WARNING in "x-internalDebugPpr" internalDebugPpr + "Don't use this function for reporting diagnostics! Use `GHC.Driver.Errors.printMessage` instead." #-} +internalDebugPpr :: forall e. Diagnostic e => MsgEnvelope e -> SDoc +internalDebugPpr = internalPprMessage (defaultDiagnosticOpts @e) + +{-# WARNING in "x-internalPprMessages" internalPprMessages + "Don't use this function for new code! It sidesteps the structured error machinery. Use `GHC.Driver.Errors.printMessages` instead." #-} +internalPprMessages :: forall e . Diagnostic e => Bag (MsgEnvelope e) -> [SDoc] +internalPprMessages = map (internalPprMessage (defaultDiagnosticOpts @e)) . sortMsgBag Nothing + +internalPprMessage :: Diagnostic e => DiagnosticOpts e -> MsgEnvelope e -> SDoc +internalPprMessage opts (MsgEnvelope { errMsgSpan = s , errMsgDiagnostic = e , errMsgSeverity = sev , errMsgContext = name_ppr_ctx , errMsgReason = reason }) = withErrStyle name_ppr_ctx $ mkLocMessage - (MCDiagnostic sev reason (diagnosticCode e)) + (InternalMCDiagnostic sev reason (diagnosticCode e)) s (formatBulleted $ diagnosticMessage opts e) ===================================== ghc/GHCi/UI/Exception.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-x-internalDebugShow #-} module GHCi.UI.Exception ( GhciCommandError(..) , throwGhciCommandError @@ -51,15 +52,12 @@ newtype GhciCommandError = GhciCommandError (Messages GhciMessage) instance Exception GhciCommandError 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. + -- We implement 'Show' because it's required by the 'Exception' instance, but + -- diagnostics must not be shown via 'Show', but instead reported via + -- `GHC.Driver.Errors.printMessages`. + -- -- This also explains why there is no 'Show' instance for a 'MsgEnvelope'. - show (GhciCommandError msgs) = - renderWithContext defaultSDocContext - . vcat - . pprMsgEnvelopeBagWithLocDefault - . getMessages - $ msgs + show (GhciCommandError msgs) = internalDebugShow 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 ===================================== @@ -3,6 +3,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -Wno-x-internalDebugShow #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -11,14 +12,11 @@ import Data.Data import Data.List (intercalate) import GHC hiding (moduleName) -import GHC.Driver.Errors.Types import GHC.Driver.Ppr import GHC.Hs.Dump -import GHC.Types.Error import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader import GHC.Utils.Error -import GHC.Utils.Outputable import System.Environment( getArgs ) import System.Exit import System.FilePath @@ -369,19 +367,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 (internalDebugShow 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 ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-x-internalDebugShow #-} -- | This module provides support for CPP, interpreter directives and line -- pragmas. module Preprocess @@ -26,13 +27,11 @@ import qualified GHC.Driver.Phases as GHC import qualified GHC.Driver.Pipeline as GHC import qualified GHC.Parser.Lexer as GHC import qualified GHC.Settings as GHC -import qualified GHC.Types.Error as GHC import qualified GHC.Types.SourceError as GHC import qualified GHC.Types.SourceFile as GHC import qualified GHC.Types.SrcLoc as GHC import qualified GHC.Utils.Error as GHC import qualified GHC.Utils.Fingerprint as GHC -import qualified GHC.Utils.Outputable as GHC import GHC.Types.SrcLoc (mkSrcSpan, mkSrcLoc) import GHC.Data.FastString (mkFastString) @@ -216,20 +215,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.internalDebugShow 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/1a6159707c6336f830ebd4a2d20aafbf... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1a6159707c6336f830ebd4a2d20aafbf... You're receiving this email because of your account on gitlab.haskell.org.
participants (1)
-
Simon Hengel (＠sol)