From be674a2c03dc7a58cfffa957eb7072f90698b94c Mon Sep 17 00:00:00 2001
From: Jade <Nils.Jadefalke@gmail.com>
Date: Fri, 2 Feb 2024 20:59:28 +0100
Subject: [PATCH] Adjust error message for trailing whitespace in as-pattern.
Fixes #22524
---
compiler/GHC/Parser/Errors/Ppr.hs | 3 ++-
compiler/GHC/Parser/Lexer.x | 17 ++++++++++++++++-
testsuite/tests/diagnostic-codes/codes.stdout | 1 -
.../tests/parser/should_fail/SuffixAtFail.hs | 3 +++
.../parser/should_fail/SuffixAtFail.stderr | 7 +++++++
testsuite/tests/parser/should_fail/all.T | 3 ++-
6 files changed, 30 insertions(+), 4 deletions(-)
create mode 100644 testsuite/tests/parser/should_fail/SuffixAtFail.hs
create mode 100644 testsuite/tests/parser/should_fail/SuffixAtFail.stderr
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index a8b2be134fdb..64e6ed992107 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -386,7 +386,8 @@ instance Diagnostic PsMessage where
-> mkSimpleDecorated $ text "primitive string literal must contain only characters <= \'\\xFF\'"
PsErrSuffixAT
-> mkSimpleDecorated $
- text "Suffix occurrence of @. For an as-pattern, remove the leading whitespace."
+ text "The symbol '@' occurs as a suffix." $$
+ text "For an as-pattern, there must not be any whitespace surrounding '@'."
PsErrPrecedenceOutOfRange i
-> mkSimpleDecorated $ text "Precedence out of range: " <> int i
PsErrSemiColonsInCondExpr c st t se e
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index cff79b44136f..596b4f7eb5aa 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -1784,6 +1784,21 @@ qvarsym, qconsym :: StringBuffer -> Int -> Token
qvarsym buf len = ITqvarsym $! splitQualName buf len False
qconsym buf len = ITqconsym $! splitQualName buf len False
+
+errSuffixAt :: PsSpan -> P a
+errSuffixAt span = do
+ input <- getInput
+ failLocMsgP start (go input start) (\srcSpan -> mkPlainErrorMsgEnvelope srcSpan $ PsErrSuffixAT)
+ where
+ start = psRealLoc (psSpanStart span)
+ go inp loc
+ | Just (c, i) <- alexGetChar inp
+ , let next = advanceSrcLoc loc c =
+ if c == ' '
+ then go i next
+ else next
+ | otherwise = loc
+
-- See Note [Whitespace-sensitive operator parsing]
varsym :: OpWs -> Action
varsym opws@OpWsPrefix = sym $ \span exts s ->
@@ -1817,7 +1832,7 @@ varsym opws@OpWsPrefix = sym $ \span exts s ->
do { warnOperatorWhitespace opws span s
; return (ITvarsym s) }
varsym opws@OpWsSuffix = sym $ \span _ s ->
- if | s == fsLit "@" -> failMsgP (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrSuffixAT)
+ if | s == fsLit "@" -> errSuffixAt span
| s == fsLit "." -> return ITdot
| otherwise ->
do { warnOperatorWhitespace opws span s
diff --git a/testsuite/tests/diagnostic-codes/codes.stdout b/testsuite/tests/diagnostic-codes/codes.stdout
index 38b6a3effe65..a189eaafd09e 100644
--- a/testsuite/tests/diagnostic-codes/codes.stdout
+++ b/testsuite/tests/diagnostic-codes/codes.stdout
@@ -34,7 +34,6 @@
[GHC-90355] is untested (constructor = PsErrLetInFunAppExpr)
[GHC-01239] is untested (constructor = PsErrIfInFunAppExpr)
[GHC-04807] is untested (constructor = PsErrProcInFunAppExpr)
-[GHC-33856] is untested (constructor = PsErrSuffixAT)
[GHC-25078] is untested (constructor = PsErrPrecedenceOutOfRange)
[GHC-18910] is untested (constructor = PsErrSemiColonsInCondCmd)
[GHC-66418] is untested (constructor = PsErrParseErrorOnInput)
diff --git a/testsuite/tests/parser/should_fail/SuffixAtFail.hs b/testsuite/tests/parser/should_fail/SuffixAtFail.hs
new file mode 100644
index 000000000000..95abe04db13a
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/SuffixAtFail.hs
@@ -0,0 +1,3 @@
+module Main where
+
+foo x@ () = ()
diff --git a/testsuite/tests/parser/should_fail/SuffixAtFail.stderr b/testsuite/tests/parser/should_fail/SuffixAtFail.stderr
new file mode 100644
index 000000000000..f2a513113a9a
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/SuffixAtFail.stderr
@@ -0,0 +1,7 @@
+
+SuffixAtFail.hs:3:6: error: [GHC-33856]
+ The symbol '@' occurs as a suffix.
+ For an as-pattern, there must not be any whitespace surrounding '@'.
+ |
+3 | foo x@ () = ()
+ | ^^^^^
diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T
index 3d5d108c76d9..d72776725110 100644
--- a/testsuite/tests/parser/should_fail/all.T
+++ b/testsuite/tests/parser/should_fail/all.T
@@ -219,4 +219,5 @@ test('T20609', normal, compile_fail, [''])
test('T20609a', normal, compile_fail, [''])
test('T20609b', normal, compile_fail, [''])
test('T20609c', normal, compile_fail, [''])
-test('T20609d', normal, compile_fail, [''])
\ No newline at end of file
+test('T20609d', normal, compile_fail, [''])
+test('SuffixAtFail', normal, compile_fail, ['-fdiagnostics-show-caret'])
--
GitLab