diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index a8b2be134fdbf3a150eb4795b93af42c737e8bd5..64e6ed992107f90db50f9543d22d16c323fb3a6f 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 cff79b44136fc3761fd2c00a79dd3882b8b26be7..596b4f7eb5aafc062c0ed3a135b49ada79d19f49 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 38b6a3effe6562e300014fb00e730fa0621e8383..a189eaafd09edc7f5799894920e40b52ec019214 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 0000000000000000000000000000000000000000..95abe04db13ad7bfce0f799634a92a21774a95fe --- /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 0000000000000000000000000000000000000000..f2a513113a9a7368fa990442cda644f70fb0105c --- /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 3d5d108c76d91bc4d091a686f2f27a9cc397f000..d72776725110d1519a1b3690e5da231e956e7aab 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'])