Lexer: turn some fatal errors into non-fatal ones

The following previously fatal lexer errors are now non-fatal:

  * errors about enabling `LambdaCase`
  * errors about enabling `NumericUnderscores`
  * errors about having valid characters in primitive strings

See #16270

4 files changed, 42 insertions, 21 deletions

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 5fb48eba36..d77564e13a 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -1312,9 +1312,11 @@ varid span buf len =
       keyword <- case lastTk of
         Just ITlam -> do
           lambdaCase <- getBit LambdaCaseBit
-          if lambdaCase
-            then return ITlcase
-            else failMsgP "Illegal lambda-case (use -XLambdaCase)"
+          unless lambdaCase $ do
+            pState <- getPState
+            addError (RealSrcSpan (last_loc pState)) $ text
+                     "Illegal lambda-case (use LambdaCase)"
+          return ITlcase
         _ -> return ITcase
       maybe_layout keyword
       return $ L span keyword
@@ -1379,9 +1381,11 @@ tok_integral :: (SourceText -> Integer -> Token)
 tok_integral itint transint transbuf translen (radix,char_to_int) span buf len = do
   numericUnderscores <- getBit NumericUnderscoresBit  -- #14473
   let src = lexemeToString buf len
-  if (not numericUnderscores) && ('_' `elem` src)
-    then failMsgP "Use NumericUnderscores to allow underscores in integer literals"
-    else return $ L span $ itint (SourceText src)
+  when ((not numericUnderscores) && ('_' `elem` src)) $ do
+    pState <- getPState
+    addError (RealSrcSpan (last_loc pState)) $ text
+             "Use NumericUnderscores to allow underscores in integer literals"
+  return $ L span $ itint (SourceText src)
        $! transint $ parseUnsignedInteger
        (offsetBytes transbuf buf) (subtract translen len) radix char_to_int
 
@@ -1419,9 +1423,11 @@ tok_frac :: Int -> (String -> Token) -> Action
 tok_frac drop f span buf len = do
   numericUnderscores <- getBit NumericUnderscoresBit  -- #14473
   let src = lexemeToString buf (len-drop)
-  if (not numericUnderscores) && ('_' `elem` src)
-    then failMsgP "Use NumericUnderscores to allow underscores in floating literals"
-    else return (L span $! (f $! src))
+  when ((not numericUnderscores) && ('_' `elem` src)) $ do
+    pState <- getPState
+    addError (RealSrcSpan (last_loc pState)) $ text
+             "Use NumericUnderscores to allow underscores in floating literals"
+  return (L span $! (f $! src))
 
 tok_float, tok_primfloat, tok_primdouble :: String -> Token
 tok_float        str = ITrational   $! readFractionalLit str
@@ -1618,23 +1624,23 @@ lex_string s = do
 
     Just ('"',i)  -> do
         setInput i
+        let s' = reverse s
         magicHash <- getBit MagicHashBit
         if magicHash
           then do
             i <- getInput
             case alexGetChar' i of
               Just ('#',i) -> do
-                   setInput i
-                   if any (> '\xFF') s
-                    then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'"
-                    else let bs = unsafeMkByteString (reverse s)
-                         in return (ITprimstring (SourceText (reverse s)) bs)
+                setInput i
+                when (any (> '\xFF') s') $ do
+                  pState <- getPState
+                  addError (RealSrcSpan (last_loc pState)) $ text
+                     "primitive string literal must contain only characters <= \'\\xFF\'"
+                return (ITprimstring (SourceText s') (unsafeMkByteString s'))
               _other ->
-                return (ITstring (SourceText (reverse s))
-                                 (mkFastString (reverse s)))
+                return (ITstring (SourceText s') (mkFastString s'))
           else
-                return (ITstring (SourceText (reverse s))
-                                 (mkFastString (reverse s)))
+                return (ITstring (SourceText s') (mkFastString s'))
 
     Just ('\\',i)
         | Just ('&',i) <- next -> do
diff --git a/testsuite/tests/parser/should_fail/ParserNoLambdaCase.stderr b/testsuite/tests/parser/should_fail/ParserNoLambdaCase.stderr
index 24d5cfc168..601262c360 100644
--- a/testsuite/tests/parser/should_fail/ParserNoLambdaCase.stderr
+++ b/testsuite/tests/parser/should_fail/ParserNoLambdaCase.stderr
@@ -1,2 +1,2 @@
 ParserNoLambdaCase.hs:3:6:
-    Illegal lambda-case (use -XLambdaCase)
+    Illegal lambda-case (use LambdaCase)
diff --git a/testsuite/tests/parser/should_fail/T16270.hs b/testsuite/tests/parser/should_fail/T16270.hs
index 0c5166d402..0147f9776a 100644
--- a/testsuite/tests/parser/should_fail/T16270.hs
+++ b/testsuite/tests/parser/should_fail/T16270.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE NoTraditionalRecordSyntax, NoDoAndIfThenElse, NoMultiWayIf #-}
+{-# LANGUAGE NoTraditionalRecordSyntax, NoDoAndIfThenElse, NoMultiWayIf, NoLambdaCase, NoNumericUnderscores, MagicHash #-}
 {-# OPTIONS -Werror=missing-space-after-bang #-}
 
 module T16270 where
@@ -29,6 +29,13 @@ multiWayIf !i = (a, b)
     b = if | i -> False
            | otherwise -> True
 
+w = \case _ : _ -> True
+          _     -> False
+
+n = 123_456
+
+s = "hello ωorld"#   -- note the omega
+
 -- a fatal error.
 k = let
 
diff --git a/testsuite/tests/parser/should_fail/T16270.stderr b/testsuite/tests/parser/should_fail/T16270.stderr
index 7eccd9516e..f4e90e40fc 100644
--- a/testsuite/tests/parser/should_fail/T16270.stderr
+++ b/testsuite/tests/parser/should_fail/T16270.stderr
@@ -57,5 +57,13 @@ T16270.hs:27:9: error:
 T16270.hs:29:9: error:
     Multi-way if-expressions need MultiWayIf turned on
 
-T16270.hs:36:1: error:
+T16270.hs:32:6: Illegal lambda-case (use LambdaCase)
+
+T16270.hs:35:5:
+    Use NumericUnderscores to allow underscores in integer literals
+
+T16270.hs:37:5:
+    primitive string literal must contain only characters <= '/xFF'
+
+T16270.hs:43:1: error:
     parse error (possibly incorrect indentation or mismatched brackets)