GitLab

Simon Jakobi pushed to branch wip/sjakobi/multi-caret at Glasgow Haskell Compiler / GHC

Commits:

3f4a9632

by Simon Jakobi at 2026-06-05T12:35:40+02:00

Read related spans from the message class in decorateDiagnostic

The related locations are already carried by the MCDiagnostic message class,
so decorateDiagnostic can take them from there rather than via a separate
parameter. This removes the redundant argument at the call sites and makes
the message class the single source of truth for the related spans.

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>

2 changed files:

compiler/GHC/Driver/Errors.hs
compiler/GHC/Utils/Logger.hs

Changes:

compiler/GHC/Driver/Errors.hs

@@ -47,7 +47,7 @@ printMessages logger msg_opts opts = mapM_ (printMessage logger msg_opts opts) .
  printMessage :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> MsgEnvelope a -> IO ()
  printMessage logger msg_opts opts message
    | log_diags_as_json = do
 -      decorated <- decorateDiagnostic logflags messageClass location relatedSpans doc
 +      decorated <- decorateDiagnostic logflags messageClass location doc
        let
          rendered :: String
          rendered = renderWithContext (log_default_user_context logflags) decorated

compiler/GHC/Utils/Logger.hs

@@ -424,8 +424,8 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg
        MCInfo                       -> printErrs msg
        MCFatal                      -> printErrs msg
        MCDiagnostic SevIgnore _ _ _ -> pure () -- suppress the message
 -      MCDiagnostic _sev _rea _code relatedSpans ->
 -        decorateDiagnostic logflags msg_class srcSpan relatedSpans msg >>= printErrs
 +      MCDiagnostic{} ->
 +        decorateDiagnostic logflags msg_class srcSpan msg >>= printErrs
      where
        printOut   = defaultLogActionHPrintDoc  logflags False out
        printErrs  = defaultLogActionHPrintDoc  logflags False err
@@ -465,13 +465,19 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg
  --     `defaultLogActionWithHandles`)
  --
  -- This story is tracked by #24113.
 -decorateDiagnostic :: LogFlags -> MessageClass -> SrcSpan -> [SrcSpan] -> SDoc -> IO SDoc
 -decorateDiagnostic logflags msg_class srcSpan relatedSpans msg = addCaret
 +decorateDiagnostic :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc
 +decorateDiagnostic logflags msg_class srcSpan msg = addCaret
      where
        -- Pretty print the warning flag, if any (#10752)
        message :: SDoc
        message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg
 +      -- The related locations are carried by the 'MCDiagnostic' message class.
 +      relatedSpans :: [SrcSpan]
 +      relatedSpans = case msg_class of
 +        MCDiagnostic _ _ _ spans -> spans
 +        _                        -> []
++
        -- The primary span is always caret'd, with the related spans drawn as
        -- additional carets.  Dedup so the primary isn't drawn twice when it
        -- also appears among the related spans.