More sensible SrcSpans for recursive pattern synonym errors (#16900)
authorRyan Scott <ryan.gl.scott@gmail.com>
Tue, 2 Jul 2019 16:55:37 +0000 (12:55 -0400)
committerMarge Bot <ben+marge-bot@smart-cactus.org>
Fri, 5 Jul 2019 11:07:38 +0000 (07:07 -0400)
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.

compiler/typecheck/TcBinds.hs
testsuite/tests/patsyn/should_fail/T16900.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/T16900.stderr [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/all.T

index 72748ac..6539c0d 100644 (file)
@@ -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 (file)
index 0000000..972c905
--- /dev/null
@@ -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 (file)
index 0000000..2838c7f
--- /dev/null
@@ -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
+  | ^^^^^^^^^^^^^^^
index 5431e8b..27ebc8b 100644 (file)
@@ -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'])