From c7f508ffe23f40e5260bca80cd5b73907c873884 Mon Sep 17 00:00:00 2001
From: Ben Davies <kaiepi@outlook.com>
Date: Wed, 20 Nov 2019 16:40:56 -0400
Subject: [PATCH] Do not show values eagerly

When attempting to show infinite lists, `ushowWith` would hang until
the process runs out of memory, despite `show` working on them. This
makes it so they can be shown using `ushow` or `ushowWith` like they
can be with `show`.
---
 src/Text/Show/Unicode.hs | 61 +++++++++++++---------------------------
 1 file changed, 19 insertions(+), 42 deletions(-)

diff --git a/src/Text/Show/Unicode.hs b/src/Text/Show/Unicode.hs
index 2e5f3a7..bd4626a 100644
--- a/src/Text/Show/Unicode.hs
+++ b/src/Text/Show/Unicode.hs
@@ -47,52 +47,26 @@ import qualified Text.Show.Unicode
 
 -}
 
-
 module Text.Show.Unicode (ushow, uprint, ushowWith, uprintWith) where
 
-import Control.Applicative ((<$>), (<$), (<|>))
-import GHC.Read (readLitChar)
-import Data.Char(isPrint)
+import Control.Applicative ((<|>))
+import Data.Char (isPrint)
+import Data.List (isSuffixOf)
+import Text.Read.Lex (lexChar)
 import Text.ParserCombinators.ReadP
 
-
-
-type Replacement = (String, String)
-
--- | Parse a value of type 'a', toghether with the original representation.
--- This is needed because a quotation mark character can be represented in two ways ---
--- @"@ or @\\"@ , and we'd like to preserve both representations.
-
-readsWithMatch :: ReadS a -> ReadS (a, String)
-readsWithMatch parser input =
-  [ ((ret, take (length input - length leftover) input), leftover)
-  | (ret, leftover) <- parser input]
-
 -- | Parse one Haskell character literal expression from a 'String' produced by 'show', and
 --
 --  * If the found char satisfies the predicate, replace the literal string with the character itself.
 --  * Otherwise, leave the string as it was.
 --  * Note that special delimiter sequence "\&" may appear in a string. c.f.  <https://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-200002.6 Section 2.6 of the Haskell 2010 specification>.
-
-recoverChar :: (Char -> Bool) -> ReadP Replacement
-recoverChar p = (represent <$> readS_to_P (readsWithMatch readLitChar)) <|> (("\\&","\\&") <$ string "\\&")
-  where
-    represent :: (Char, String) -> Replacement
-    represent (c,original) | p c  = (original, [c])
-    represent (_,original)        = (original, original)
-
--- | Parse many Haskell character literals from the input,
--- and concatenate them.
-reparse :: (Char -> Bool) -> ReadP String
-reparse p = cat2 ("","") <$> many (recoverChar p)
+recoverChar :: (Char -> Bool) -> ReadP String
+recoverChar p = represent <$> gather lexChar <|> string "\\&"
   where
-    -- concatenate while removing redundant separator.
-    cat2 :: Replacement -> [Replacement] -> String
-    cat2 _ [] = ""
-    cat2 (pb,pa) ((xb,xa):xs)
-      | pb /= pa && xb == "\\&"  =       cat2 (xb,xa) xs
-      | otherwise                = xa ++ cat2 (xb,xa) xs
-
+    represent :: (String, Char) -> String
+    represent (ec,c)
+      | p c       = [c]
+      | otherwise = ec
 
 -- | Show the input, and then replace Haskell character literals
 -- with the character it represents, for any Unicode printable characters except backslash, single and double quotation marks.
@@ -104,15 +78,18 @@ ushow = ushowWith (\c -> isPrint c && not (c `elem` ['\\', '\'','\"'] ))
 uprint :: Show a => a -> IO ()
 uprint = putStrLn . ushow
 
-
 -- | Show the input, and then replace character literals
 -- with the character itself, for characters that satisfy the given predicate.
 ushowWith :: Show a => (Char -> Bool) -> a -> String
-ushowWith p x = let showx = show x in case readP_to_S (reparse p) $ showx of
-           [] -> showx
-           ys -> case last ys of
-             (ret,"") -> ret
-             _        -> showx
+ushowWith p x = go $ readP_to_S (many $ recoverChar p) (show x)
+  where
+    go :: [([String], String)] -> String
+    go []            = ""
+    go (([],""):[])  = ""
+    go ((rs,""):[])  = last rs
+    go ((_,o):[])    = o
+    go (([],_):rest) = go rest
+    go ((rs,_):rest) = last rs ++ go rest
 
 -- | A version of 'print' that uses 'ushowWith'.
 uprintWith :: Show a => (Char -> Bool) -> a -> IO ()