Bugfix for bug 11632: `readLitChar` should consume null characters

Test Plan: The tests have been included. This change deals with a
relatively minor edge case and should not break unrelated functionality.

Reviewers: thomie, #core_libraries_committee, ekmett, bgamari

Reviewed By: #core_libraries_committee, ekmett, bgamari

Subscribers: bgamari, ekmett

Differential Revision: https://phabricator.haskell.org/D2391

GHC Trac Issues: #11632

4 files changed, 25 insertions, 3 deletions

diff --git a/libraries/base/GHC/Read.hs b/libraries/base/GHC/Read.hs
index 54fbc287a8..d7df82f1f6 100644
--- a/libraries/base/GHC/Read.hs
+++ b/libraries/base/GHC/Read.hs
@@ -229,7 +229,13 @@ lex s  = readP_to_S L.hsLex s
 --
 lexLitChar :: ReadS String      -- As defined by H2010
 lexLitChar = readP_to_S (do { (s, _) <- P.gather L.lexChar ;
-                              return s })
+                              let s' = removeNulls s in
+                              return s' })
+    where
+    -- remove nulls from end of the character if they exist
+    removeNulls [] = []
+    removeNulls ('\\':'&':xs) = removeNulls xs
+    removeNulls (first:rest) = first : removeNulls rest
         -- There was a skipSpaces before the P.gather L.lexChar,
         -- but that seems inconsistent with readLitChar
 
diff --git a/libraries/base/Text/Read/Lex.hs b/libraries/base/Text/Read/Lex.hs
index 7054be9d79..d0d39c6648 100644
--- a/libraries/base/Text/Read/Lex.hs
+++ b/libraries/base/Text/Read/Lex.hs
@@ -253,7 +253,16 @@ lexLitChar =
      return (Char c)
 
 lexChar :: ReadP Char
-lexChar = do { (c,_) <- lexCharE; return c }
+lexChar = do { (c,_) <- lexCharE; consumeEmpties; return c }
+    where
+    -- Consumes the string "\&" repeatedly and greedily (will only produce one match)
+    consumeEmpties :: ReadP ()
+    consumeEmpties = do
+        rest <- look
+        case rest of
+            ('\\':'&':_) -> string "\\&" >> consumeEmpties
+            _ -> return ()
+
 
 lexCharE :: ReadP (Char, Bool)  -- "escaped or not"?
 lexCharE =
diff --git a/libraries/base/tests/readLitChar.hs b/libraries/base/tests/readLitChar.hs
index 7dc01e36e4..e287d2232a 100644
--- a/libraries/base/tests/readLitChar.hs
+++ b/libraries/base/tests/readLitChar.hs
@@ -9,4 +9,7 @@ main =
        putStrLn (show $ readLitChar "'A'")
        putStrLn (show $ lexLitChar "A")
        putStrLn (show $ lexLitChar "'A'")
-
+       putStrLn (show $ lexLitChar "\\243\\&1")
+       putStrLn (show $ lexLitChar "a\\&1")
+       putStrLn (show $ lexLitChar "a\\&\\&1")
+       putStrLn (show $ lexLitChar "a\\&\\&")
diff --git a/libraries/base/tests/readLitChar.stdout b/libraries/base/tests/readLitChar.stdout
index 649c342e4a..db7bc5b1b4 100644
--- a/libraries/base/tests/readLitChar.stdout
+++ b/libraries/base/tests/readLitChar.stdout
@@ -2,3 +2,7 @@
 [('\'',"A'")]
 [("A","")]
 [("'","A'")]
+[("\\243","1")]
+[("a","1")]
+[("a","1")]
+[("a","")]