Simon Jakobi pushed to branch wip/sjakobi/multi-caret at Glasgow Haskell Compiler / GHC Commits: e2180816 by Simon Jakobi at 2026-05-25T17:51:00+02:00 Add support for related locations in Diagnostic * Convert TcRnBindingNameConflict to demonstrate this feature. * Enable -fdiagnostics-show-caret in some tests to show what error messages with multiple caret sections look like. This prepares the ground for #22637. The diagnosticRelatedLocations name is inspired by #23414. - - - - - 12 changed files: - compiler/GHC/Driver/Errors.hs - compiler/GHC/Driver/Errors/Ppr.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Utils/Logger.hs - testsuite/tests/patsyn/should_fail/T14114.stderr - testsuite/tests/patsyn/should_fail/all.T - testsuite/tests/rename/should_fail/all.T - testsuite/tests/rename/should_fail/rnfail004.stderr - testsuite/tests/typecheck/should_fail/all.T - testsuite/tests/typecheck/should_fail/tcfail038.stderr Changes: ===================================== compiler/GHC/Driver/Errors.hs ===================================== @@ -15,6 +15,7 @@ import GHC.Utils.Json import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Logger +import Data.List.NonEmpty (NonEmpty(..)) reportError :: Logger -> NamePprCtx -> DiagOpts -> SrcSpan -> SDoc -> IO () reportError logger nameContext opts span doc = do @@ -47,7 +48,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 doc + decorated <- decorateDiagnostic logflags messageClass location sourceSpans doc let rendered :: String rendered = renderWithContext (log_default_user_context logflags) decorated @@ -57,7 +58,7 @@ printMessage logger msg_opts opts message logJsonMsg logger messageClass jsonMessage - | otherwise = logMsg logger messageClass location doc + | otherwise = logMsg (pushLogHook renderWithSourceSpans logger) messageClass location doc where logflags :: LogFlags logflags = logFlags logger @@ -80,9 +81,21 @@ printMessage logger msg_opts opts message diagnostic :: a diagnostic = errMsgDiagnostic message + sourceSpans :: NonEmpty SrcSpan + sourceSpans = location :| diagnosticRelatedLocations diagnostic + 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/Errors/Ppr.hs ===================================== @@ -87,6 +87,18 @@ instance Diagnostic GhcMessage where diagnosticCode = constructorCode @GHC + diagnosticRelatedLocations = \case + GhcPsMessage m + -> diagnosticRelatedLocations m + GhcTcRnMessage m + -> diagnosticRelatedLocations m + GhcDsMessage m + -> diagnosticRelatedLocations m + GhcDriverMessage m + -> diagnosticRelatedLocations m + GhcUnknownMessage m + -> diagnosticRelatedLocations m + instance HasDefaultDiagnosticOpts DriverMessageOpts where defaultOpts = DriverMessageOpts (defaultDiagnosticOpts @PsMessage) (defaultDiagnosticOpts @IfaceMessage) ===================================== compiler/GHC/Rename/Utils.hs ===================================== @@ -660,9 +660,10 @@ mkNameClashErr gre_env rdr_name gres = TcRnAmbiguousName gre_env rdr_name gres dupNamesErr :: NE.NonEmpty SrcSpan -> NE.NonEmpty RdrName -> RnM () dupNamesErr locs names - = addErrAt big_loc (TcRnBindingNameConflict (NE.head names) locs) + = addErrAt (NE.head sorted_locs) + (TcRnBindingNameConflict (NE.head names) sorted_locs) where - big_loc = foldr1 combineSrcSpans locs + sorted_locs = NE.sortBy leftmost_smallest locs badQualBndrErr :: RdrName -> TcRnMessage badQualBndrErr rdr_name = TcRnQualifiedBinder rdr_name ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -3455,6 +3455,18 @@ instance Diagnostic TcRnMessage where diagnosticCode = constructorCode @GHC + diagnosticRelatedLocations = \case + TcRnUnknownMessage m + -> diagnosticRelatedLocations m + TcRnMessageWithInfo _ (TcRnMessageDetailed _ msg') + -> diagnosticRelatedLocations msg' + TcRnWithHsDocContext _ msg' + -> diagnosticRelatedLocations msg' + TcRnBindingNameConflict _ locs + -> NE.tail locs + _ -> + [] + pprTcRnBadlyLevelled :: LevelCheckReason -> Set.Set ThLevelIndex -> ThLevelIndex -> Maybe ErrorItem -> DecoratedSDoc pprTcRnBadlyLevelled reason bind_lvls use_lvl lift_attempt = mkDecorated $ [ fsep [ text "Level error:", pprLevelCheckReason reason ===================================== compiler/GHC/Types/Error.hs ===================================== @@ -66,6 +66,7 @@ module GHC.Types.Error , mkLocMessageWarningGroups , formatDiagnostic , getCaretDiagnostic + , getCaretDiagnostics , jsonDiagnostic @@ -108,8 +109,8 @@ import Data.Bifunctor import Data.Foldable import Data.List.NonEmpty ( NonEmpty (..) ) import qualified Data.List.NonEmpty as NE -import Data.List ( intercalate ) -import Data.Maybe ( maybeToList ) +import Data.List ( intercalate, sort ) +import Data.Maybe ( mapMaybe, maybeToList ) import Data.Typeable ( Typeable ) import Numeric.Natural ( Natural ) import Text.Printf ( printf ) @@ -277,6 +278,13 @@ class (Outputable (DiagnosticHint a), HasDefaultDiagnosticOpts (DiagnosticOpts a -- #18516 tracks our progress toward this goal. diagnosticCode :: a -> Maybe DiagnosticCode + -- | Additional locations related to this diagnostic. + -- + -- When rendering caret diagnostics, these locations are shown alongside the + -- message's primary location. + diagnosticRelatedLocations :: a -> [SrcSpan] + diagnosticRelatedLocations _ = [] + -- | An existential wrapper around an unknown diagnostic. data UnknownDiagnostic opts hint where UnknownDiagnostic :: (Diagnostic a, Typeable a) @@ -295,6 +303,7 @@ instance (HasDefaultDiagnosticOpts opts, Outputable hint) => Diagnostic (Unknown diagnosticReason (UnknownDiagnostic _ _ diag) = diagnosticReason diag diagnosticHints (UnknownDiagnostic _ f diag) = map f (diagnosticHints diag) diagnosticCode (UnknownDiagnostic _ _ diag) = diagnosticCode diag + diagnosticRelatedLocations (UnknownDiagnostic _ _ diag) = diagnosticRelatedLocations diag -- A fallback 'DiagnosticOpts' which can be used when there are no options -- for a particular diagnostic. @@ -785,7 +794,25 @@ getSeverityColour severity = case severity of SevIgnore -> const mempty getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc -getCaretDiagnostic msg_class (RealSrcSpan span _) = +getCaretDiagnostic msg_class span = getCaretDiagnostics msg_class (span :| []) + +getCaretDiagnostics :: MessageClass -> NonEmpty SrcSpan -> IO SDoc +getCaretDiagnostics msg_class spans = do + let realSpans = dedupSortedRealSpans spans + maxMarginWidth = + foldl' (\acc s -> max acc (length (show (srcSpanStartLine s)))) 0 realSpans + vcat <$> traverse (getSingleCaretDiagnostic msg_class maxMarginWidth) realSpans + where + dedupSortedRealSpans :: NonEmpty SrcSpan -> [RealSrcSpan] + dedupSortedRealSpans = go Nothing . sort . mapMaybe srcSpanToRealSrcSpan . NE.toList + where + go _ [] = [] + go prev (span:rest) + | Just span == prev = go prev rest + | otherwise = span : go (Just span) rest + +getSingleCaretDiagnostic :: MessageClass -> Int -> RealSrcSpan -> IO SDoc +getSingleCaretDiagnostic msg_class maxMarginWidth span = caretDiagnostic <$> getSrcLine (srcSpanFile span) row where getSrcLine fn i = @@ -848,9 +875,9 @@ getCaretDiagnostic msg_class (RealSrcSpan span _) = | otherwise = srcSpanEndCol span - 1 width = max 1 (end - start) - marginWidth = length rowStr + marginWidth = maxMarginWidth marginSpace = replicate marginWidth ' ' ++ " |" - marginRow = rowStr ++ " |" + marginRow = replicate (marginWidth - length rowStr) ' ' ++ rowStr ++ " |" (srcLinePre, srcLineRest) = splitAt start srcLine (srcLineSpan, srcLinePost) = splitAt width srcLineRest @@ -858,7 +885,6 @@ getCaretDiagnostic msg_class (RealSrcSpan span _) = caretEllipsis | multiline = "..." | otherwise = "" caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis -getCaretDiagnostic _ _ = pure empty -- -- Queries -- ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -84,7 +84,7 @@ import GHC.Prelude import GHC.Driver.Flags import GHC.Types.Error ( MessageClass (..), Severity (..) - , mkLocMessageWarningGroups,getCaretDiagnostic ) + , mkLocMessageWarningGroups, getCaretDiagnostics ) -- import GHC.Types.Error () import GHC.Types.SrcLoc @@ -102,6 +102,7 @@ import System.FilePath ( takeDirectory, (</>) ) import qualified Data.Map.Strict as Map import Data.Map.Strict (Map) import Data.List (stripPrefix) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Time import System.IO import Control.Monad @@ -423,7 +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 -> decorateDiagnostic logflags msg_class srcSpan msg >>= printErrs + MCDiagnostic _sev _rea _code -> + decorateDiagnostic logflags msg_class srcSpan (srcSpan :| []) msg >>= printErrs where printOut = defaultLogActionHPrintDoc logflags False out printErrs = defaultLogActionHPrintDoc logflags False err @@ -463,8 +465,8 @@ defaultLogActionWithHandles out err logflags msg_class srcSpan msg -- `defaultLogActionWithHandles`) -- -- This story is tracked by #24113. -decorateDiagnostic :: LogFlags -> MessageClass -> SrcSpan -> SDoc -> IO SDoc -decorateDiagnostic logflags msg_class srcSpan msg = addCaret +decorateDiagnostic :: LogFlags -> MessageClass -> SrcSpan -> NonEmpty SrcSpan -> SDoc -> IO SDoc +decorateDiagnostic logflags msg_class srcSpan sourceSpans msg = addCaret where -- Pretty print the warning flag, if any (#10752) message :: SDoc @@ -474,7 +476,7 @@ decorateDiagnostic logflags msg_class srcSpan msg = addCaret addCaret = do caretDiagnostic <- if log_show_caret logflags - then getCaretDiagnostic msg_class srcSpan + then getCaretDiagnostics msg_class sourceSpans else pure empty return $ getPprStyle $ \style -> withPprStyle (setStyleColoured True style) ===================================== testsuite/tests/patsyn/should_fail/T14114.stderr ===================================== @@ -1,18 +1,36 @@ - T14114.hs:4:20: error: [GHC-10498] • Conflicting definitions for ‘a’ Bound at: T14114.hs:4:20 T14114.hs:4:22 • In a pattern synonym declaration + | +4 | pattern Foo1 a <- (a,a) + | ^ + | +4 | pattern Foo1 a <- (a,a) + | ^ T14114.hs:5:20: error: [GHC-10498] • Conflicting definitions for ‘a’ Bound at: T14114.hs:5:20 T14114.hs:5:22 • In a pattern synonym declaration + | +5 | pattern Foo2 a = (a,a) + | ^ + | +5 | pattern Foo2 a = (a,a) + | ^ T14114.hs:6:20: error: [GHC-10498] • Conflicting definitions for ‘a’ Bound at: T14114.hs:6:20 T14114.hs:6:22 • In a pattern synonym declaration + | +6 | pattern Foo3 a <- (a,a) where + | ^ + | +6 | pattern Foo3 a <- (a,a) where + | ^ + ===================================== testsuite/tests/patsyn/should_fail/all.T ===================================== @@ -40,7 +40,7 @@ test('T26465', normal, compile_fail, ['']) test('T13349', normal, compile_fail, ['']) test('T13470', normal, compile_fail, ['']) test('T14112', normal, compile_fail, ['']) -test('T14114', normal, compile_fail, ['']) +test('T14114', normal, compile_fail, ['-fdiagnostics-show-caret']) test('T14507', normal, compile_fail, ['-dsuppress-uniques']) test('T15289', normal, compile_fail, ['']) test('T15685', normal, compile_fail, ['']) ===================================== testsuite/tests/rename/should_fail/all.T ===================================== @@ -1,7 +1,7 @@ test('rnfail001', normal, compile_fail, ['']) test('rnfail002', normal, compile_fail, ['']) test('rnfail003', normal, compile_fail, ['']) -test('rnfail004', normal, compile_fail, ['']) +test('rnfail004', normal, compile_fail, ['-fdiagnostics-show-caret']) test('rnfail007', normal, compile_fail, ['']) test('rnfail008', normal, compile_fail, ['']) test('rnfail009', normal, compile_fail, ['']) ===================================== testsuite/tests/rename/should_fail/rnfail004.stderr ===================================== @@ -1,10 +1,22 @@ - -rnfail004.hs:6:5: [GHC-10498] +rnfail004.hs:6:5: error: [GHC-10498] Conflicting definitions for ‘a’ Bound at: rnfail004.hs:6:5 rnfail004.hs:7:10 + | +6 | a = [] + | ^ + | +7 | (b,c,a) = ([],[],d) + | ^ -rnfail004.hs:7:6: [GHC-10498] +rnfail004.hs:7:6: error: [GHC-10498] Conflicting definitions for ‘b’ Bound at: rnfail004.hs:7:6 rnfail004.hs:8:8 + | +7 | (b,c,a) = ([],[],d) + | ^ + | +8 | [d,b,_] = ([],a,[]) + | ^ + ===================================== testsuite/tests/typecheck/should_fail/all.T ===================================== @@ -31,7 +31,7 @@ test('tcfail034', normal, compile_fail, ['']) test('tcfail035', normal, compile_fail, ['']) test('tcfail036', normal, compile_fail, ['']) test('tcfail037', normal, compile_fail, ['']) -test('tcfail038', normal, compile_fail, ['']) +test('tcfail038', normal, compile_fail, ['-fdiagnostics-show-caret']) test('tcfail040', normal, compile_fail, ['']) test('tcfail041', normal, compile_fail, ['']) test('tcfail042', normal, compile_fail, ['']) ===================================== testsuite/tests/typecheck/should_fail/tcfail038.stderr ===================================== @@ -1,10 +1,22 @@ - -tcfail038.hs:7:11: [GHC-10498] +tcfail038.hs:7:11: error: [GHC-10498] Conflicting definitions for ‘==’ Bound at: tcfail038.hs:7:11-12 tcfail038.hs:9:11-12 + | +7 | a == b = True + | ^^ + | +9 | a == b = False + | ^^ -tcfail038.hs:8:11: [GHC-10498] +tcfail038.hs:8:11: error: [GHC-10498] Conflicting definitions for ‘/=’ Bound at: tcfail038.hs:8:11-12 tcfail038.hs:10:11-12 + | + 8 | a /= b = False + | ^^ + | +10 | a /= b = True + | ^^ + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e2180816b5e571ff4da284400f2ff59e... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e2180816b5e571ff4da284400f2ff59e... You're receiving this email because of your account on gitlab.haskell.org.