Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 49a44ab7 by Simon Hengel at 2025-07-23T17:59:55+07:00 Refactor GHC.Driver.Errors.printMessages - - - - - 84711c39 by Simon Hengel at 2025-07-23T18:27:34+07:00 Respect `-fdiagnostics-as-json` for error messages from pre-processors (fixes #25480) - - - - - 3 changed files: - compiler/GHC/Driver/Errors.hs - compiler/GHC/SysTools/Process.hs - ghc/GHCi/UI.hs Changes: ===================================== compiler/GHC/Driver/Errors.hs ===================================== @@ -1,33 +1,75 @@ {-# LANGUAGE ScopedTypeVariables #-} module GHC.Driver.Errors ( - printOrThrowDiagnostics + reportError + , reportDiagnostic , printMessages + , printOrThrowDiagnostics , mkDriverPsHeaderMessage ) where import GHC.Driver.Errors.Types import GHC.Prelude +import GHC.Types.SrcLoc import GHC.Types.SourceError import GHC.Types.Error import GHC.Utils.Error -import GHC.Utils.Outputable (hang, ppr, ($$), text, mkErrStyle, sdocStyle, updSDocContext ) +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 msgs - = sequence_ [ let style = mkErrStyle name_ppr_ctx - ctx = (diag_ppr_ctx opts) { sdocStyle = style } - in (if log_diags_as_json - then logJsonMsg logger (MCDiagnostic sev reason (diagnosticCode dia)) msg - else logMsg logger (MCDiagnostic sev reason (diagnosticCode dia)) s $ - updSDocContext (\_ -> ctx) (messageWithHints dia)) - | msg@MsgEnvelope { errMsgSpan = s, - errMsgDiagnostic = dia, - errMsgSeverity = sev, - errMsgReason = reason, - errMsgContext = name_ppr_ctx } - <- sortMsgBag (Just opts) (getMessages msgs) ] +printMessages logger msg_opts opts = mapM_ (printMessage logger msg_opts opts) . sortMessages + where + sortMessages :: Messages a -> [MsgEnvelope a] + 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 = logJsonMsg logger messageClass message + | otherwise = logMsg logger messageClass location doc where + doc :: SDoc + doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic) + + messageClass :: MessageClass + messageClass = MCDiagnostic severity (errMsgReason message) (diagnosticCode diagnostic) + + style :: PprStyle + style = mkErrStyle (errMsgContext message) + + location :: SrcSpan + location = errMsgSpan message + + ctx :: SDocContext + ctx = (diag_ppr_ctx opts) { sdocStyle = style } + + diagnostic :: a + diagnostic = errMsgDiagnostic message + + severity :: Severity + severity = errMsgSeverity message + messageWithHints :: a -> SDoc messageWithHints e = let main_msg = formatBulleted $ diagnosticMessage msg_opts e @@ -36,6 +78,8 @@ printMessages logger msg_opts opts msgs [h] -> main_msg $$ hang (text "Suggested fix:") 2 (ppr h) 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) -- | Given a bag of diagnostics, turn them into an exception if ===================================== 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/c865623baff0a6355337443eb5415cb... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c865623baff0a6355337443eb5415cb... You're receiving this email because of your account on gitlab.haskell.org.