[Git][ghc/ghc][wip/T18856] Fix error message location in tcCheckPatSynDecl

[Simon Peyton Jones]

Simon Peyton Jones pushed to branch wip/T18856 at Glasgow Haskell Compiler / GHC


Commits:
f3d70111 by Simon Peyton Jones at 2020-10-21T13:20:40+01:00
Fix error message location in tcCheckPatSynDecl

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 changed files:

- compiler/GHC/Tc/TyCl/PatSyn.hs
- testsuite/tests/patsyn/should_fail/T11010.stderr
- + testsuite/tests/patsyn/should_fail/T18856.hs
- + testsuite/tests/patsyn/should_fail/T18856.stderr
- testsuite/tests/patsyn/should_fail/all.T


Changes:

=====================================
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 at 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)


=====================================
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
+  |                                  ^


=====================================
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)])
+


=====================================
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)])
+  |                      ^


=====================================
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'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f3d70111d1d69bf11ac374f4071cbd21a29b9d06

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f3d70111d1d69bf11ac374f4071cbd21a29b9d06
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201021/d443193d/attachment-0001.html>