Fix error message location in tcCheckPatSynDeclwip/T18856

Ticket #18856 showed that we were failing to set the right location
for an error message.  Easy to fix, happily.

Turns out that this also improves the error location in test T11010,
which was bogus before but we had never noticed.

5 files changed, 40 insertions, 7 deletions

diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index 79d3f97077..e470b21ce6 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -31,9 +31,9 @@ import GHC.Tc.Utils.TcMType
 import GHC.Tc.Utils.Zonk
 import GHC.Builtin.Types.Prim
 import GHC.Types.Name
+import GHC.Types.Name.Set
 import GHC.Types.SrcLoc
 import GHC.Core.PatSyn
-import GHC.Types.Name.Set
 import GHC.Utils.Panic
 import GHC.Utils.Outputable
 import GHC.Data.FastString
@@ -422,14 +422,22 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
        ; tc_patsyn_finish lname dir is_infix lpat'
                           (univ_bndrs, req_theta, ev_binds, req_dicts)
                           (ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts)
-                          (args', (map scaledThing arg_tys))
+                          (args', map scaledThing arg_tys)
                           pat_ty rec_fields }
   where
     tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTc)
+     -- Look up the variable actually bound by lpat
+     -- and check that it has the expected type
     tc_arg subst arg_name arg_ty
-      = do {   -- Look up the variable actually bound by lpat
-               -- and check that it has the expected type
-             arg_id <- tcLookupId arg_name
+      = setSrcSpan (nameSrcSpan arg_name) $
+           -- Set the SrcSpan to be the binding site of the Id (#18856)
+           -- e.g.  pattern P :: Int -> Maybe (Int,Bool)
+           --       pattern P x = Just (x,True)
+           -- Before unifying x's actual type with its expected type, in tc_arg, set
+           -- location to x's binding site in lpat, namely the 'x' in Just (x,True).
+           -- Else the error message location is wherever tcCheckPat finished,
+           -- namely the right-hand corner of the pattern
+        do { arg_id <- tcLookupId arg_name
            ; wrap <- tcSubTypeSigma GenSigCtxt
                                     (idType arg_id)
                                     (substTyUnchecked subst arg_ty)
diff --git a/testsuite/tests/patsyn/should_fail/T11010.stderr b/testsuite/tests/patsyn/should_fail/T11010.stderr
index 28216760ee..af081b6a36 100644
--- a/testsuite/tests/patsyn/should_fail/T11010.stderr
+++ b/testsuite/tests/patsyn/should_fail/T11010.stderr
@@ -1,5 +1,5 @@
 
-T11010.hs:9:36: error:
+T11010.hs:9:34: error:
     • Couldn't match type ‘a1’ with ‘Int’
       Expected: a -> b
         Actual: a1 -> b
@@ -12,3 +12,6 @@ T11010.hs:9:36: error:
     • Relevant bindings include
         x :: Expr a1 (bound at T11010.hs:9:36)
         f :: a1 -> b (bound at T11010.hs:9:34)
+  |
+9 | pattern IntFun str f x = Fun str f x
+  |                                  ^
diff --git a/testsuite/tests/patsyn/should_fail/T18856.hs b/testsuite/tests/patsyn/should_fail/T18856.hs
new file mode 100644
index 0000000000..780a734d53
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/T18856.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
+
+module T18856 where
+
+pattern P ::  Int -> Bool -> (Int, Bool, [(Bool,Bool)])
+pattern P p q <- (q, p, [(True,False)])
+
diff --git a/testsuite/tests/patsyn/should_fail/T18856.stderr b/testsuite/tests/patsyn/should_fail/T18856.stderr
new file mode 100644
index 0000000000..ceee029102
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/T18856.stderr
@@ -0,0 +1,14 @@
+
+T18856.hs:6:19: error:
+    • Couldn't match expected type ‘Bool’ with actual type ‘Int’
+    • In the declaration for pattern synonym ‘P’
+  |
+6 | pattern P p q <- (q, p, [(True,False)])
+  |                   ^
+
+T18856.hs:6:22: error:
+    • Couldn't match expected type ‘Int’ with actual type ‘Bool’
+    • In the declaration for pattern synonym ‘P’
+  |
+6 | pattern P p q <- (q, p, [(True,False)])
+  |                      ^
diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T
index 02cc2cec2c..5faea83c88 100644
--- a/testsuite/tests/patsyn/should_fail/all.T
+++ b/testsuite/tests/patsyn/should_fail/all.T
@@ -9,7 +9,7 @@ test('T9705-2', normal, compile_fail, [''])
 test('unboxed-bind', normal, compile_fail, [''])
 test('unboxed-wrapper-naked', normal, compile_fail, [''])
 test('T10873', normal, compile_fail, [''])
-test('T11010', normal, compile_fail, [''])
+test('T11010', normal, compile_fail, ['-fdiagnostics-show-caret'])
 test('records-check-sels', normal, compile_fail, [''])
 test('records-no-uni-update', normal, compile_fail, [''])
 test('records-no-uni-update2', normal, compile_fail, [''])
@@ -47,3 +47,4 @@ test('T15692', normal, compile, [''])   # It has -fdefer-type-errors inside
 test('T15694', normal, compile_fail, [''])
 test('T16900', normal, compile_fail, ['-fdiagnostics-show-caret'])
 test('T14552', normal, compile_fail, [''])
+test('T18856', normal, compile_fail, ['-fdiagnostics-show-caret'])