Do not show values eagerly

src/Text/Show/Unicode.hs

@@ -47,52 +47,29 @@ 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
 
-
-
+-- Represents a replaced character using its literal form and its escaped form.
 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 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) -> Replacement
+    represent (o,lc)
+      | p lc      = (o, [lc])
+      | otherwise = (o, o)
 
 -- | 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 +81,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 :: Replacement -> [([Replacement], String)] -> String
+    go _  []            = ""
+    go _  (([],""):_)   = ""
+    go pr ((rs,""):_)   = snd $ last rs
+    go _  ((_,o):[])    = o
+    go pr (([],_):rest) = go pr rest
+    go pr ((rs,o):rest) = let r = last rs in snd r ++ go r rest
 
 -- | A version of 'print' that uses 'ushowWith'.
 uprintWith :: Show a => (Char -> Bool) -> a -> IO ()