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 @@ -47,52 +47,28 @@ -} - module Text.Show.Unicode (ushow, uprint, ushowWith, uprintWith) where -import Control.Applicative ((<$>), (<$), (<|>)) -import GHC.Read (readLitChar) -import Data.Char(isPrint) -import Text.ParserCombinators.ReadP - - +import Control.Applicative ((<|>)) +import Data.Char (isPrint) +import Text.ParserCombinators.ReadP +import Text.Read.Lex (lexChar) +-- 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 +80,18 @@ 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 _ ((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 -- | 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,55 +1,58 @@ {-# LANGUAGE ScopedTypeVariables #-} -import Test.Framework (defaultMain, testGroup) -import Test.Framework.Providers.API (Test) -import Test.Framework.Providers.HUnit (testCase) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit.Base hiding (Test) +import Test.Hspec +import Test.Hspec.QuickCheck -import Text.Show.Unicode +import Text.Show.Unicode data T試6験 = Å4 { すけろく :: String} deriving (Eq, Ord, Show, Read) data T試7験 = String :@\& String deriving (Eq, Ord, Show, Read) data T試8験 = String :＠\& String deriving (Eq, Ord, Show, Read) -ushowTo :: Show a => a -> String -> Test -ushowTo f t = testCase ("ushow " ++ show f ++ " == " ++ t) $ t @=? ushow f +ushowTo :: Show a => a -> String -> Spec +ushowTo f t = it ("ushow " ++ show f ++ " == " ++ t) $ t `shouldBe` ushow f -tests :: [Test] -tests = - [ testGroup "individual representations test" - [ "صباح الخير" `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\"" - ] +spec :: Spec +spec = + 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\"" - , testGroup "read . ushow == id" - [ testProperty "read . ushow == id, for String" $ - \str -> read (ushow str) == (str :: String) - , testProperty "read . ushow == id, for Char" $ - \x -> read (ushow x) == (x :: Char) - , testProperty "read . ushow == id, for [(Char,())]" $ - \x -> read (ushow x) == (x :: [(Char,())]) - , testProperty "read . read . ushow . ushow == id, for String" $ - \str -> (read $ read $ ushow $ ushow str) == (str :: String) - , testProperty "read . ushow == id, for some crazy Unicode type" $ - \str -> let v = Å4 str in read (ushow v) == v - , testProperty "read . ushow == id, for some crazy Unicode type" $ - \a b -> let v = a :@\& b in read (ushow v) == v - , testProperty "read . ushow == id, for some crazy Unicode type" $ - \a b -> let v = a :＠\& b in read (show v) == v - , testProperty "read . ushow == id, for compound type" $ - \str -> read (ushow str) == (str :: Either [String] (String,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 . read . ushow . ushow == id, for String" $ + \str -> (read $ read $ ushow $ ushow str) `shouldBe` (str :: String) + + prop "read . ushow == id, for some crazy Unicode type" $ + \str -> let v = Å4 str in read (ushow v) `shouldBe` v + + prop "read . ushow == id, for some crazy Unicode type" $ + \a b -> let v = a :@\& b in read (ushow v) `shouldBe` v + + prop "read . ushow == id, for some crazy Unicode type" $ + \a b -> let v = a :＠\& b in read (ushow v) `shouldBe` v + + 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" - defaultMain tests + 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.0.3 +version: 0.1.0.4 synopsis: print and show in unicode description: This package provides variants of 'show' and 'print' functions that does not escape non-ascii characters. @@ -33,12 +33,9 @@ hs-source-dirs: test main-is: Spec.hs build-depends: base - , HUnit + , hspec , QuickCheck , unicode-show - , test-framework - , test-framework-hunit - , test-framework-quickcheck2 ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010