More sensible SrcSpans for recursive pattern synonym errors (#16900)

Attach the `SrcSpan` of the first pattern synonym binding involved in
the recursive group when throwing the corresponding error message,
similarly to how it is done for type synonyms.

Fixes #16900.

4 files changed, 26 insertions, 6 deletions

diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 72748ac76f..6539c0d3e2 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -67,6 +67,7 @@ import qualified GHC.LanguageExtensions as LangExt
 import ConLike
 
 import Control.Monad
+import Data.Foldable (find)
 
 #include "HsVersions.h"
 
@@ -485,12 +486,13 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
         -- (This used to be optional, but isn't now.)
         -- See Note [Polymorphic recursion] in HsBinds.
     do  { traceTc "tc_group rec" (pprLHsBinds binds)
-        ; when hasPatSyn $ recursivePatSynErr binds
+        ; whenIsJust mbFirstPatSyn $ \lpat_syn ->
+            recursivePatSynErr (getLoc lpat_syn) binds
         ; (binds1, thing) <- go sccs
         ; return ([(Recursive, binds1)], thing) }
                 -- Rec them all together
   where
-    hasPatSyn = anyBag (isPatSyn . unLoc) binds
+    mbFirstPatSyn = find (isPatSyn . unLoc) binds
     isPatSyn PatSynBind{} = True
     isPatSyn _ = False
 
@@ -511,10 +513,14 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
     tc_sub_group rec_tc binds =
       tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds
 
-recursivePatSynErr :: OutputableBndrId (GhcPass p) =>
-                      LHsBinds (GhcPass p) -> TcM a
-recursivePatSynErr binds
-  = failWithTc $
+recursivePatSynErr ::
+     OutputableBndrId (GhcPass p) =>
+     SrcSpan -- ^ The location of the first pattern synonym binding
+             --   (for error reporting)
+  -> LHsBinds (GhcPass p)
+  -> TcM a
+recursivePatSynErr loc binds
+  = failAt loc $
     hang (text "Recursive pattern synonym definition with following bindings:")
        2 (vcat $ map pprLBind . bagToList $ binds)
   where
diff --git a/testsuite/tests/patsyn/should_fail/T16900.hs b/testsuite/tests/patsyn/should_fail/T16900.hs
new file mode 100644
index 0000000000..972c90530a
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/T16900.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE PatternSynonyms #-}
+module T16900 where
+
+pattern P1 = P2
+pattern P2 = P1
diff --git a/testsuite/tests/patsyn/should_fail/T16900.stderr b/testsuite/tests/patsyn/should_fail/T16900.stderr
new file mode 100644
index 0000000000..2838c7f867
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/T16900.stderr
@@ -0,0 +1,8 @@
+
+T16900.hs:4:1: error:
+    Recursive pattern synonym definition with following bindings:
+      P1 (defined at T16900.hs:4:1-15)
+      P2 (defined at T16900.hs:5:1-15)
+  |
+4 | pattern P1 = P2
+  | ^^^^^^^^^^^^^^^
diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T
index 5431e8b76a..27ebc8bdd4 100644
--- a/testsuite/tests/patsyn/should_fail/all.T
+++ b/testsuite/tests/patsyn/should_fail/all.T
@@ -45,3 +45,4 @@ test('T15289', normal, compile_fail, [''])
 test('T15685', normal, compile_fail, [''])
 test('T15692', normal, compile, [''])   # It has -fdefer-type-errors inside
 test('T15694', normal, compile_fail, [''])
+test('T16900', normal, compile_fail, ['-fdiagnostics-show-caret'])