Improve parser error messages for the @-operator

Since GHC diverges from the Haskell Report by allowing the user
to define (@) as an infix operator, we better give a good
error message when the user does so unintentionally.

In general, this is rather hard to do, as some failures will be
discovered only in the renamer or the type checker:

	x :: (Integer, Integer)
	x @ (a, b) = (1, 2)

This patch does *not* address this general case.

However, it gives much better error messages when the binding
is not syntactically valid:

	pairs xs @ (_:xs') = zip xs xs'

Before this patch, the error message was rather puzzling:

	<interactive>:1:1: error: Parse error in pattern: pairs

After this patch, the error message includes a hint:

	<interactive>:1:1: error:
	    Parse error in pattern: pairs
	    In a function binding for the ‘@’ operator.
	    Perhaps you meant an as-pattern, which must not be surrounded by whitespace

8 files changed, 46 insertions, 2 deletions

diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 88475120b8..82a8b9398f 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -1137,6 +1137,13 @@ checkAPat loc e0 = do
                       | nPlusKPatterns && (plus == plus_RDR)
                       -> return (mkNPlusKPat (L nloc n) (L lloc lit))
 
+   -- Improve error messages for the @-operator when the user meant an @-pattern
+   PatBuilderOpApp _ op _ | opIsAt (unLoc op) -> do
+     addError (getLoc op) $
+       text "Found a binding for the" <+> quotes (ppr op) <+> text "operator in a pattern position." $$
+       perhaps_as_pat
+     return (WildPat noExtField)
+
    PatBuilderOpApp l (L cl c) r
      | isRdrDataCon c -> do
          l <- checkLPat l
@@ -1171,6 +1178,9 @@ patFail loc e = addFatalError loc $ text "Parse error in pattern:" <+> ppr e
 patIsRec :: RdrName -> Bool
 patIsRec e = e == mkUnqual varName (fsLit "rec")
 
+opIsAt :: RdrName -> Bool
+opIsAt e = e == mkUnqual varName (fsLit "@")
+
 ---------------------------------------------------------------------------
 -- Check Equation Syntax
 
@@ -1203,7 +1213,7 @@ checkFunBind :: SrcStrictness
              -> Located (GRHSs GhcPs (LHsExpr GhcPs))
              -> P ([AddAnn],HsBind GhcPs)
 checkFunBind strictness ann lhs_loc fun is_infix pats (L rhs_span grhss)
-  = do  ps <- mapM checkPattern pats
+  = do  ps <- runPV_msg param_hint (mapM checkLPat pats)
         let match_span = combineSrcSpans lhs_loc rhs_span
         -- Add back the annotations stripped from any HsPar values in the lhs
         -- mapM_ (\a -> a match_span) ann
@@ -1217,6 +1227,15 @@ checkFunBind strictness ann lhs_loc fun is_infix pats (L rhs_span grhss)
                                        , m_grhss = grhss })])
         -- The span of the match covers the entire equation.
         -- That isn't quite right, but it'll do for now.
+  where
+    param_hint
+      | Infix <- is_infix
+      = text "In a function binding for the" <+> quotes (ppr fun) <+> text "operator." $$
+        if opIsAt (unLoc fun) then perhaps_as_pat else empty
+      | otherwise = empty
+
+perhaps_as_pat :: SDoc
+perhaps_as_pat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"
 
 makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
             -> HsBind GhcPs
diff --git a/testsuite/tests/parser/should_fail/T18251a.hs b/testsuite/tests/parser/should_fail/T18251a.hs
new file mode 100644
index 0000000000..81511258fc
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T18251a.hs
@@ -0,0 +1,3 @@
+module T18251a where
+
+pairs xs @ (_:xs') = zip xs xs'
diff --git a/testsuite/tests/parser/should_fail/T18251a.stderr b/testsuite/tests/parser/should_fail/T18251a.stderr
new file mode 100644
index 0000000000..abdfd68e64
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T18251a.stderr
@@ -0,0 +1,5 @@
+
+T18251a.hs:3:1: error:
+    Parse error in pattern: pairs
+    In a function binding for the ‘@’ operator.
+    Perhaps you meant an as-pattern, which must not be surrounded by whitespace
diff --git a/testsuite/tests/parser/should_fail/T18251b.hs b/testsuite/tests/parser/should_fail/T18251b.hs
new file mode 100644
index 0000000000..affd027abd
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T18251b.hs
@@ -0,0 +1,3 @@
+module T18251a where
+
+pairs (xs @ (_:xs')) = zip xs xs'
diff --git a/testsuite/tests/parser/should_fail/T18251b.stderr b/testsuite/tests/parser/should_fail/T18251b.stderr
new file mode 100644
index 0000000000..0dab383d52
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T18251b.stderr
@@ -0,0 +1,4 @@
+
+T18251b.hs:3:11: error:
+    Found a binding for the ‘@’ operator in a pattern position.
+    Perhaps you meant an as-pattern, which must not be surrounded by whitespace
diff --git a/testsuite/tests/parser/should_fail/T18251f.hs b/testsuite/tests/parser/should_fail/T18251f.hs
new file mode 100644
index 0000000000..8711d5788f
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T18251f.hs
@@ -0,0 +1,3 @@
+module T18251f where
+
+f ! x y = x + y
diff --git a/testsuite/tests/parser/should_fail/T18251f.stderr b/testsuite/tests/parser/should_fail/T18251f.stderr
new file mode 100644
index 0000000000..fa859fa06a
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T18251f.stderr
@@ -0,0 +1,4 @@
+
+T18251f.hs:3:5: error:
+    Parse error in pattern: x
+    In a function binding for the ‘!’ operator.
diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T
index 9d71019f3e..8256906296 100644
--- a/testsuite/tests/parser/should_fail/all.T
+++ b/testsuite/tests/parser/should_fail/all.T
@@ -166,4 +166,7 @@ test('T17162', normal, compile_fail, [''])
 test('proposal-229c', normal, compile_fail, [''])
 test('T15730', normal, compile_fail, [''])
 test('T15730b', normal, compile_fail, [''])
-test('T18130Fail', normal, compile_fail, ['']) 
+test('T18130Fail', normal, compile_fail, [''])
+test('T18251a', normal, compile_fail, [''])
+test('T18251b', normal, compile_fail, [''])
+test('T18251f', normal, compile_fail, [''])