diff --git a/src/Text/Show/Unicode.hs b/src/Text/Show/Unicode.hs --- a/src/Text/Show/Unicode.hs +++ b/src/Text/Show/Unicode.hs @@ -49,48 +49,19 @@ module Text.Show.Unicode (ushow, uprint, urecover, ushowWith, uprintWith, urecoverWith) where -import Control.Applicative ((<|>)) -import Data.Char (isAscii, isPrint) -import Text.ParserCombinators.ReadP -import Text.Read.Lex (lexChar) -import qualified Data.List as L +import Control.Monad.Trans.State.Strict (StateT (StateT, runStateT), + get, put) +import Data.Char (isAscii, isPrint) +import qualified Data.List as L +import qualified Data.Ord as O +import Safe (minimumByMay) +import Text.ParserCombinators.ReadP (gather, readP_to_S) +import Text.Read.Lex (lexChar) --- Represents a replaced character using its literal form and its escaped form. -type Replacement = (String, String) +-- | Create a parser for less dependencies. ReadP is too slow +type Parser a = StateT String Maybe a --- | 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 <$> gather lexCharAndConsumeEmpties - where - represent :: (String, Char) -> Replacement - represent (o,lc) - -- This is too dirty a hack. - -- However, I couldn't think of any other way to recover the & consumed by lexChar while not needlessly increasing the number of & by mis-detecting the escape sequence. - | p lc = - if head o /= '\\' && - "\\&" `L.isSuffixOf` o - then (o, lc : "\\&") - else (o, [lc]) - | otherwise = (o, o) --- | The base library lexChar has been handling & by itself since 4.9.1.0, --- so consumeEmpties is a meaningless action, --- but it makes sense for older versions of lexChar. -lexCharAndConsumeEmpties :: ReadP Char -lexCharAndConsumeEmpties = lexChar <* consumeEmpties - where - -- Consumes the string "\&" repeatedly and greedily (will only produce one match) - consumeEmpties :: ReadP () - consumeEmpties = do - rest <- look - case rest of - ('\\':'&':_) -> string "\\&" >> consumeEmpties - _ -> return () - -- | 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. -- If something fails, fallback to standard 'show'. @@ -118,15 +89,46 @@ -- | Replace character literals with the character itself, for characters that -- satisfy the given predicate. urecoverWith :: (Char -> Bool) -> String -> String -urecoverWith p = go ("", "") . readP_to_S (many $ recoverChar p) +urecoverWith p s = + case runStateT (recoverChars p) s of + Just (r, left) -> r ++ left + Nothing -> s + + +recoverChars :: (Char -> Bool) -> Parser String +recoverChars p = outsideLiteral where - go :: Replacement -> [([Replacement], String)] -> String - go _ [] = "" - go _ (([],""):_) = "" - go _ ((rs,""):_) = snd $ last rs - go _ [(_,o)] = o - go pr (([],_):rest) = go pr rest - go _ ((rs,_):rest) = let r = last rs in snd r ++ go r rest + outsideLiteral = do + notLit <- untilDoubleQuote + rest <- get + case rest of + '\"' : inLiteral -> do + put inLiteral + (notLit ++) . ('\"' :) <$> insideLiteral + _ -> + return $ notLit ++ rest + + insideLiteral = do + recovered <- recoverCharInLiteral + case recovered of + ("\"",'"') -> ('"' :) <$> outsideLiteral + (s, c) + | p c -> (c :) <$> insideLiteral + | otherwise -> (s ++) <$> insideLiteral + + untilDoubleQuote = StateT $ Just . L.break (== '\"') + + +-- | Parse one Haskell character literal expression from a 'String' produced by 'show', and +-- returns the pair of the string before parsed with the parsed character. +-- * Note that special delimiter sequence "\&" may appear in a string. c.f. . +recoverCharInLiteral :: Parser (String, Char) +recoverCharInLiteral = StateT $ \s -> + let result = readP_to_S (gather lexChar) s + -- The longest match result should leave the shortest string. + -- So choose the result with the minimum length left. + in minimumByMay (O.comparing (length . snd)) result + -- | A version of 'print' that uses 'ushowWith'. uprintWith :: Show a => (Char -> Bool) -> a -> IO () diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,6 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} - +import Control.Monad (when) import Test.Hspec import Test.Hspec.QuickCheck import Text.Read (readMaybe) @@ -14,7 +14,7 @@ data T試10験 = String :\&\& String deriving (Eq, Ord, Show, Read) ushowTo :: Show a => a -> String -> Spec -ushowTo f t = it ("ushow " ++ show f ++ " == " ++ t) $ t `shouldBe` ushow f +ushowTo f t = it ("ushow " ++ show f ++ " == " ++ t) $ ushow f `shouldBe` t -- | check `read . ushow == id` when `read . show == id`. -- The reason why we don't test if the show fails is that older versions may fail to read the result of the show, @@ -22,57 +22,54 @@ -- ==> is not used because it will cause an error if there is no test case that can be executed. readUShowIsIdWhenOkPrelude :: (Eq a, Show a, Read a) => a -> Expectation readUShowIsIdWhenOkPrelude v = - if preludeOk - then ushowOk - else pure () + when preludeOk ushowOk where preludeOk = readMaybe (show v) == Just v ushowOk = read (ushow v) `shouldBe` v spec :: Spec -spec = +spec = do describe "individual representations test" $ do - describe "individual representations test" $ do - "صباح الخير" `ushowTo` "\"صباح الخير\"" - "😆💕>λ\\=🐘" `ushowTo` "\"😆💕>λ\\\\=🐘\"" - "漢6" `ushowTo` "\"漢6\"" - "\32\&7" `ushowTo` "\" 7\"" - "改\n行" `ushowTo` "\"改\\n行\"" - "下一站\na\ri\ta国际机场" `ushowTo` "\"下一站\\na\\ri\\ta国际机场\"" - "\SOH\SO\&H" `ushowTo` "\"\\SOH\\SO\\&H\"" + "صباح الخير" `ushowTo` "\"صباح الخير\"" + "😆💕>λ\\=🐘" `ushowTo` "\"😆💕>λ\\\\=🐘\"" + "漢6" `ushowTo` "\"漢6\"" + "\32\&7" `ushowTo` "\" 7\"" + "改\n行" `ushowTo` "\"改\\n行\"" + "下一站\na\ri\ta国际机场" `ushowTo` "\"下一站\\na\\ri\\ta国际机场\"" + "\SOH\SO\&H" `ushowTo` "\"\\SOH\\SO\\&H\"" + "\"\"" `ushowTo` "\"\\\"\\\"\"" + "\"" `ushowTo` "\"\\\"\"" + "\"unterminated" `ushowTo` "\"\\\"unterminated\"" - describe "read . ushow == id" $ do - prop "read . ushow == id, for String" $ - \str -> read (ushow str) `shouldBe` (str :: String) + describe "read . ushow == id" $ do + prop "read . ushow == id, for String" $ + \str -> read (ushow str) `shouldBe` (str :: String) - prop "read . ushow == id, for Char" $ - \x -> read (ushow x) `shouldBe` (x :: Char) + prop "read . ushow == id, for Char" $ + \x -> read (ushow x) `shouldBe` (x :: Char) - prop "read . ushow == id, for [(Char,())]" $ - \x -> read (ushow x) `shouldBe` (x :: [(Char,())]) + prop "read . ushow == id, for [(Char,())]" $ + \x -> read (ushow x) `shouldBe` (x :: [(Char,())]) - prop "read . read . ushow . ushow == id, for String" $ - \str -> read (read $ ushow $ ushow str) `shouldBe` (str :: String) + prop "read . read . ushow . ushow == id, for String" $ + \str -> read (read $ ushow $ ushow str) `shouldBe` (str :: String) - prop "read . ushow == id, for some crazy Unicode type: T試6験" $ - \str -> readUShowIsIdWhenOkPrelude $ Å4 str + prop "read . ushow == id, for some crazy Unicode type: T試6験" $ + \str -> readUShowIsIdWhenOkPrelude $ Å4 str - prop "read . ushow == id, for some crazy Unicode type: T試7験" $ - \a b -> readUShowIsIdWhenOkPrelude $ a :@\& b + prop "read . ushow == id, for some crazy Unicode type: T試7験" $ + \a b -> readUShowIsIdWhenOkPrelude $ a :@\& b - prop "read . ushow == id, for some crazy Unicode type: T試8験" $ - \a b -> readUShowIsIdWhenOkPrelude $ a :＠\& b + prop "read . ushow == id, for some crazy Unicode type: T試8験" $ + \a b -> readUShowIsIdWhenOkPrelude $ a :＠\& b - prop "read . ushow == id, for some crazy Unicode type: T試9験" $ - \a b -> readUShowIsIdWhenOkPrelude $ a :\&＠\& b + prop "read . ushow == id, for some crazy Unicode type: T試9験" $ + \a b -> readUShowIsIdWhenOkPrelude $ a :\&＠\& b - prop "read . ushow == id, for some crazy Unicode type: T試10験" $ - \a b -> readUShowIsIdWhenOkPrelude $ a :\&\& b + prop "read . ushow == id, for some crazy Unicode type: T試10験" $ + \a b -> readUShowIsIdWhenOkPrelude $ a :\&\& b - prop "read . ushow == id, for compound type" $ - \str -> read (ushow str) `shouldBe` (str :: Either [String] (String,String)) + prop "read . ushow == id, for compound type" $ + \str -> read (ushow str) `shouldBe` (str :: Either [String] (String,String)) main :: IO () -main = do - print $ "hoge" :@\& "huga" - putStrLn $ ushow $ "hoge" :@\& "huga" - hspec spec +main = hspec spec diff --git a/unicode-show.cabal b/unicode-show.cabal --- a/unicode-show.cabal +++ b/unicode-show.cabal @@ -1,5 +1,5 @@ name: unicode-show -version: 0.1.1.0 +version: 0.1.1.1 synopsis: print and show in unicode description: This package provides variants of 'show' and 'print' functions that does not escape non-ascii characters. @@ -15,7 +15,7 @@ license: BSD3 license-file: LICENSE author: Takayuki Muranushi -maintainer: whosekiteneverfly@gmail.com +maintainer: igrep@n.email.ne.jp copyright: 2016 Takayuki Muranushi category: Text build-type: Simple @@ -26,6 +26,8 @@ hs-source-dirs: src exposed-modules: Text.Show.Unicode build-depends: base >= 4.8.1.0 && < 5 + , transformers >= 0.4.0.0 + , safe >= 0.3.5 default-language: Haskell2010 test-suite unicode-show-test