Simon Hengel pushed to branch wip/sol/core-diagnostics at Glasgow Haskell Compiler / GHC Commits: 84711c39 by Simon Hengel at 2025-07-23T18:27:34+07:00 Respect `-fdiagnostics-as-json` for error messages from pre-processors (fixes #25480) - - - - - da200c22 by Simon Hengel at 2025-07-23T18:48:15+07:00 Respect `-fdiagnostics-as-json` for core diagnostics (see #24113) - - - - - 6 changed files: - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Driver/Errors.hs - compiler/GHC/SysTools/Process.hs - ghc/GHCi/UI.hs Changes: ===================================== compiler/GHC/Core/Opt/Monad.hs ===================================== @@ -33,7 +33,7 @@ module GHC.Core.Opt.Monad ( getAnnotations, getFirstAnnotations, -- ** Screen output - putMsg, putMsgS, errorMsg, msg, + putMsg, putMsgS, errorMsg, msg, diagnostic, fatalErrorMsg, fatalErrorMsgS, debugTraceMsg, debugTraceMsgS, ) where @@ -41,6 +41,8 @@ module GHC.Core.Opt.Monad ( import GHC.Prelude hiding ( read ) import GHC.Driver.DynFlags +import GHC.Driver.Errors ( reportDiagnostic, reportError ) +import GHC.Driver.Config.Diagnostic ( initDiagOpts ) import GHC.Driver.Env import GHC.Core.Rules ( RuleBase, RuleEnv, mkRuleEnv ) @@ -52,7 +54,6 @@ import GHC.Types.Name.Env import GHC.Types.SrcLoc import GHC.Types.Error -import GHC.Utils.Error ( errorDiagnostic ) import GHC.Utils.Outputable as Outputable import GHC.Utils.Logger import GHC.Utils.Monad @@ -383,9 +384,22 @@ putMsgS = putMsg . text putMsg :: SDoc -> CoreM () putMsg = msg MCInfo +diagnostic :: DiagnosticReason -> SDoc -> CoreM () +diagnostic reason doc = do + logger <- getLogger + loc <- getSrcSpanM + name_ppr_ctx <- getNamePprCtx + diag_opts <- initDiagOpts <$> getDynFlags + liftIO $ reportDiagnostic logger name_ppr_ctx diag_opts loc reason doc + -- | Output an error to the screen. Does not cause the compiler to die. errorMsg :: SDoc -> CoreM () -errorMsg doc = msg errorDiagnostic doc +errorMsg doc = do + logger <- getLogger + loc <- getSrcSpanM + name_ppr_ctx <- getNamePprCtx + diag_opts <- initDiagOpts <$> getDynFlags + liftIO $ reportError logger name_ppr_ctx diag_opts loc doc -- | Output a fatal error to the screen. Does not cause the compiler to die. fatalErrorMsgS :: String -> CoreM () ===================================== compiler/GHC/Core/Opt/SpecConstr.hs ===================================== @@ -45,7 +45,7 @@ import GHC.Core.Make ( mkImpossibleExpr ) import GHC.Unit.Module import GHC.Unit.Module.ModGuts -import GHC.Types.Error (MessageClass(..), Severity(..), DiagnosticReason(WarningWithoutFlag), ResolvedDiagnosticReason (..)) +import GHC.Types.Error (DiagnosticReason(..)) import GHC.Types.Literal ( litIsLifted ) import GHC.Types.Id import GHC.Types.Id.Info ( IdDetails(..) ) @@ -783,12 +783,11 @@ specConstrProgram guts ; let (_usg, binds', warnings) = initUs_ us $ scTopBinds env0 (mg_binds guts) - ; when (not (null warnings)) $ msg specConstr_warn_class (warn_msg warnings) + ; when (not (null warnings)) $ diagnostic WarningWithoutFlag (warn_msg warnings) ; return (guts { mg_binds = binds' }) } where - specConstr_warn_class = MCDiagnostic SevWarning (ResolvedDiagnosticReason WarningWithoutFlag) Nothing warn_msg :: SpecFailWarnings -> SDoc warn_msg warnings = text "SpecConstr encountered one or more function(s) with a SPEC argument that resulted in too many arguments," $$ text "which resulted in no specialization being generated for these functions:" $$ ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -12,7 +12,6 @@ import GHC.Prelude import GHC.Driver.DynFlags import GHC.Driver.Config -import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Core.Type hiding( substTy, substCo, extendTvSubst, zapSubst ) @@ -55,7 +54,6 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Error -import GHC.Utils.Error ( mkMCDiagnostic ) import GHC.Utils.Monad ( foldlM ) import GHC.Utils.Misc import GHC.Utils.Outputable @@ -938,10 +936,12 @@ tryWarnMissingSpecs dflags callers fn calls_for_fn | wopt Opt_WarnAllMissedSpecs dflags = doWarn $ WarningWithFlag Opt_WarnAllMissedSpecs | otherwise = return () where + allCallersInlined :: Bool allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers - diag_opts = initDiagOpts dflags + + doWarn :: DiagnosticReason -> CoreM () doWarn reason = - msg (mkMCDiagnostic diag_opts reason Nothing) + diagnostic reason (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn)) 2 (vcat [ text "when specialising" <+> quotes (ppr caller) | caller <- callers]) ===================================== compiler/GHC/Driver/Errors.hs ===================================== @@ -1,7 +1,9 @@ {-# LANGUAGE ScopedTypeVariables #-} module GHC.Driver.Errors ( - printOrThrowDiagnostics + reportError + , reportDiagnostic , printMessages + , printOrThrowDiagnostics , mkDriverPsHeaderMessage ) where @@ -14,6 +16,28 @@ import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Logger +reportError :: Logger -> NamePprCtx -> DiagOpts -> SrcSpan -> SDoc -> IO () +reportError logger nameContext opts span doc = do + let + message :: MsgEnvelope DiagnosticMessage + message = mkErrorMsgEnvelope span nameContext DiagnosticMessage { + diagMessage = mkDecorated [doc] + , diagReason = ErrorWithoutFlag + , diagHints = [] + } + printMessage logger NoDiagnosticOpts opts message + +reportDiagnostic :: Logger -> NamePprCtx -> DiagOpts -> SrcSpan -> DiagnosticReason -> SDoc -> IO () +reportDiagnostic logger nameContext opts span reason doc = do + let + message :: MsgEnvelope DiagnosticMessage + message = mkMsgEnvelope opts span nameContext DiagnosticMessage { + diagMessage = mkDecorated [doc] + , diagReason = reason + , diagHints = [] + } + printMessage logger NoDiagnosticOpts opts message + printMessages :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO () printMessages logger msg_opts opts = mapM_ (printMessage logger msg_opts opts) . sortMessages where ===================================== compiler/GHC/SysTools/Process.hs ===================================== @@ -26,6 +26,8 @@ import GHC.Utils.Logger import GHC.Utils.TmpFs import GHC.Utils.CliOption +import GHC.Driver.Errors (reportError) + import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, mkSrcSpan ) import GHC.Data.FastString @@ -286,8 +288,7 @@ builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = withPipe $ \ (rea BuildMsg msg -> do logInfo logger $ withPprStyle defaultUserStyle msg BuildError loc msg -> do - logMsg logger errorDiagnostic (mkSrcSpan loc loc) - $ withPprStyle defaultUserStyle msg + reportError logger neverQualify emptyDiagOpts (mkSrcSpan loc loc) msg parseBuildMessages :: [String] -> [BuildMessage] parseBuildMessages str = loop str Nothing ===================================== ghc/GHCi/UI.hs ===================================== @@ -53,7 +53,7 @@ import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Core.PatSyn import GHC.Driver.Flags -import GHC.Driver.Errors +import GHC.Driver.Errors (printOrThrowDiagnostics) import GHC.Driver.Errors.Types import GHC.Driver.Phases import GHC.Driver.Session as DynFlags View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/79950b03e8234b9c92da27f19eac452... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/79950b03e8234b9c92da27f19eac452... You're receiving this email because of your account on gitlab.haskell.org.