diff --git a/src/Text/Show/Unicode.hs b/src/Text/Show/Unicode.hs index 2e5f3a7..97b3981 100644 --- a/src/Text/Show/Unicode.hs +++ b/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. . - 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 ()