Simon Jakobi pushed to branch wip/sjakobi/multi-caret at Glasgow Haskell Compiler / GHC Commits: b8806c7d by Simon Jakobi at 2026-05-26T12:41:25+02:00 Hack: Carry diagnostic related spans through MessageClass - - - - - 8 changed files: - compiler/GHC/Core/Opt/Monad.hs - compiler/GHC/Driver/Errors.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Types/Error.hs-boot - compiler/GHC/Utils/Error.hs - compiler/GHC/Utils/Logger.hs - ghc/GHCi/UI.hs Changes: ===================================== compiler/GHC/Core/Opt/Monad.hs ===================================== @@ -369,7 +369,7 @@ msg msg_class doc = do loc <- getSrcSpanM name_ppr_ctx <- getNamePprCtx let sty = case msg_class of - MCDiagnostic _ _ _ -> err_sty + MCDiagnostic _ _ _ _ -> err_sty MCDump -> dump_sty _ -> user_sty err_sty = mkErrStyle name_ppr_ctx ===================================== compiler/GHC/Driver/Errors.hs ===================================== @@ -58,7 +58,7 @@ printMessage logger msg_opts opts message logJsonMsg logger messageClass jsonMessage - | otherwise = logMsg (pushLogHook renderWithSourceSpans logger) messageClass location doc + | otherwise = logMsg logger messageClass location doc where logflags :: LogFlags logflags = logFlags logger @@ -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 = MCDiagnostic severity (errMsgReason message) (diagnosticCode diagnostic) relatedSpans style :: PprStyle style = mkErrStyle (errMsgContext message) @@ -81,21 +81,15 @@ printMessage logger msg_opts opts message diagnostic :: a diagnostic = errMsgDiagnostic message + relatedSpans :: [SrcSpan] + relatedSpans = diagnosticRelatedLocations diagnostic + sourceSpans :: NonEmpty SrcSpan - sourceSpans = location :| diagnosticRelatedLocations diagnostic + sourceSpans = location :| relatedSpans severity :: Severity severity = errMsgSeverity message - renderWithSourceSpans :: LogAction -> LogAction - renderWithSourceSpans fallback logflags' msg_class' srcSpan' msg' = - case msg_class' of - MCDiagnostic _ _ _ -> do - decorated <- decorateDiagnostic logflags' msg_class' srcSpan' sourceSpans msg' - fallback logflags' MCInfo noSrcSpan decorated - _ -> - fallback logflags' msg_class' srcSpan' msg' - messageWithHints :: a -> SDoc messageWithHints e = let main_msg = formatBulleted $ diagnosticMessage msg_opts e ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -1426,9 +1426,9 @@ withDeferredDiagnostics f = do let deferDiagnostics _dflags !msgClass !srcSpan !msg = do let action = logMsg logger msgClass srcSpan msg case msgClass of - MCDiagnostic SevWarning _reason _code + MCDiagnostic SevWarning _reason _code _relatedSpans -> atomicModifyIORef' warnings $ \(!i) -> (action: i, ()) - MCDiagnostic SevError _reason _code + MCDiagnostic SevError _reason _code _relatedSpans -> atomicModifyIORef' errors $ \(!i) -> (action: i, ()) MCFatal -> atomicModifyIORef' fatals $ \(!i) -> (action: i, ()) ===================================== compiler/GHC/Types/Error.hs ===================================== @@ -491,7 +491,7 @@ data MessageClass -- ^ Log messages intended for end users. -- No file\/line\/column stuff. - | MCDiagnostic Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) + | MCDiagnostic Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) [SrcSpan] -- ^ 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, @@ -505,6 +505,9 @@ data MessageClass -- 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]. + -- + -- The list of 'SrcSpan's carries additional locations related to the + -- diagnostic. The primary location is supplied separately to the 'LogAction'. {- Note [Suppressing Messages] @@ -564,7 +567,7 @@ instance ToJson MessageClass where json MCInteractive = JSString "MCInteractive" json MCDump = JSString "MCDump" json MCInfo = JSString "MCInfo" - json (MCDiagnostic sev reason code) = + json (MCDiagnostic sev reason code _) = JSString $ renderWithContext defaultSDocContext (ppr $ text "MCDiagnostic" <+> ppr sev <+> ppr reason <+> ppr code) instance ToJson DiagnosticCode where @@ -658,7 +661,7 @@ mkLocMessageWarningGroups -> SDoc mkLocMessageWarningGroups show_warn_groups msg_class locn msg = case msg_class of - MCDiagnostic severity reason code -> formatDiagnostic show_warn_groups locn severity reason code msg + MCDiagnostic severity reason code _ -> formatDiagnostic show_warn_groups locn severity reason code msg _ -> sdocOption sdocColScheme $ \col_scheme -> let msg_colour = getMessageClassColour msg_class col_scheme @@ -783,7 +786,7 @@ formatLocMessageWarningGroups locn msg_title code_doc warning_flag_doc msg msg) getMessageClassColour :: MessageClass -> Col.Scheme -> Col.PprColour -getMessageClassColour (MCDiagnostic severity _reason _code) = getSeverityColour severity +getMessageClassColour (MCDiagnostic severity _reason _code _) = getSeverityColour severity getMessageClassColour MCFatal = Col.sFatal getMessageClassColour _ = const mempty ===================================== compiler/GHC/Types/Error.hs-boot ===================================== @@ -10,7 +10,7 @@ data MessageClass | MCInteractive | MCDump | MCInfo - | MCDiagnostic Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) + | MCDiagnostic Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) [SrcSpan] data Severity = SevIgnore ===================================== compiler/GHC/Utils/Error.hs ===================================== @@ -287,7 +287,7 @@ pprLocMsgEnvelope opts (MsgEnvelope { errMsgSpan = s , errMsgReason = reason }) = withErrStyle name_ppr_ctx $ mkLocMessage - (MCDiagnostic sev reason (diagnosticCode e)) + (MCDiagnostic sev reason (diagnosticCode e) (diagnosticRelatedLocations e)) s (formatBulleted $ diagnosticMessage opts e) ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -370,8 +370,8 @@ defaultLogJsonAction logflags msg_class jsdoc = MCInteractive -> putStrSDoc msg MCInfo -> printErrs msg MCFatal -> printErrs msg - MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message - MCDiagnostic _sev _rea _code -> printErrs msg + MCDiagnostic SevIgnore _ _ _ -> pure () -- suppress the message + MCDiagnostic _sev _rea _code _ -> printErrs msg where printOut = defaultLogActionHPrintDoc logflags False stdout printErrs = defaultLogActionHPrintDoc logflags False stderr @@ -381,7 +381,7 @@ defaultLogJsonAction logflags msg_class jsdoc = -- See Note [JSON Error Messages] -- this is to be removed jsonLogActionWithHandle :: Handle {-^ Standard out -} -> LogAction -jsonLogActionWithHandle _ _ (MCDiagnostic SevIgnore _ _) _ _ = return () -- suppress the message +jsonLogActionWithHandle _ _ (MCDiagnostic SevIgnore _ _ _) _ _ = return () -- suppress the message jsonLogActionWithHandle out logflags msg_class srcSpan msg = defaultLogActionHPutStrDoc logflags True out @@ -423,9 +423,9 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg MCInteractive -> putStrSDoc msg MCInfo -> printErrs msg MCFatal -> printErrs msg - MCDiagnostic SevIgnore _ _ -> pure () -- suppress the message - MCDiagnostic _sev _rea _code -> - decorateDiagnostic logflags msg_class srcSpan (srcSpan :| []) msg >>= printErrs + MCDiagnostic SevIgnore _ _ _ -> pure () -- suppress the message + MCDiagnostic _sev _rea _code relatedSpans -> + decorateDiagnostic logflags msg_class srcSpan (srcSpan :| relatedSpans) msg >>= printErrs where printOut = defaultLogActionHPrintDoc logflags False out printErrs = defaultLogActionHPrintDoc logflags False err ===================================== ghc/GHCi/UI.hs ===================================== @@ -914,7 +914,7 @@ ghciLogAction lastErrLocations old_log_action dflags msg_class srcSpan msg = do old_log_action dflags msg_class srcSpan msg case msg_class of - MCDiagnostic SevError _reason _code -> case srcSpan of + MCDiagnostic SevError _reason _code _relatedSpans -> case srcSpan of RealSrcSpan rsp _ -> modifyIORef lastErrLocations (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))]) _ -> return () View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b8806c7da29c8ab8147b3c49750d5c0c... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b8806c7da29c8ab8147b3c49750d5c0c... You're receiving this email because of your account on gitlab.haskell.org.