diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -3,17 +3,13 @@ module Main where -import Control.Monad.Trans.Resource (MonadThrow) import Criterion.Main import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BSI -import Data.Conduit (Conduit, (=$=)) import qualified Data.Vector.Storable as DVS import Data.Word import Foreign import HaskellWorks.Data.Conduit.ByteString -import HaskellWorks.Data.Conduit.Json -import HaskellWorks.Data.Conduit.Json.Blank import HaskellWorks.Data.Conduit.List import System.IO.MMap @@ -35,51 +31,6 @@ let !bs = BSI.fromForeignPtr (castForeignPtr fptr) offset size return bs -runCon :: Conduit i [] BS.ByteString -> i -> BS.ByteString -runCon con bs = BS.concat $ runListConduit con [bs] - -runCon2 :: Conduit i [] o -> [i] -> [o] -runCon2 con is = let os = runListConduit con is in seq (length os) os - -runCon3 :: Conduit i [] BS.ByteString -> [i] -> [BS.ByteString] -runCon3 con is = let os = runListConduit con is in seq (BS.length (last os)) os - -jsonToInterestBits3 :: MonadThrow m => Conduit BS.ByteString m BS.ByteString -jsonToInterestBits3 = blankJson =$= blankedJsonToInterestBits - -benchRankJson40Conduits :: [Benchmark] -benchRankJson40Conduits = - [ env (setupEnvJson "/Users/jky/Downloads/part40.json") $ \bs -> bgroup "Json40" - [ bench "Run blankJson " (whnf (runCon blankJson ) bs) - , bench "Run jsonToInterestBits3 " (whnf (runCon jsonToInterestBits3 ) bs) - ] - ] - -benchRankJson80Conduits :: [Benchmark] -benchRankJson80Conduits = - [ env (setupEnvJson "/Users/jky/Downloads/part80.json") $ \bs -> bgroup "Json40" - [ bench "Run blankJson " (whnf (runCon blankJson ) bs) - , bench "Run jsonToInterestBits3 " (whnf (runCon jsonToInterestBits3 ) bs) - ] - ] - -benchRankJsonBigConduits :: [Benchmark] -benchRankJsonBigConduits = - [ env (setupEnvJson "/Users/jky/Downloads/78mb.json") $ \bs -> bgroup "JsonBig" - [ bench "Run blankJson " (whnf (runCon blankJson ) bs) - , bench "Run jsonToInterestBits3 " (whnf (runCon jsonToInterestBits3 ) bs) - ] - ] - -benchBlankedJsonToBalancedParens :: [Benchmark] -benchBlankedJsonToBalancedParens = - [ env (setupEnvJson "/Users/jky/Downloads/part40.json") $ \bs -> bgroup "JsonBig" - [ bench "blankedJsonToBalancedParens2" (whnf (runCon2 blankedJsonToBalancedParens) [bs]) - , bench "blankedJsonToBalancedParens2" (whnf (runCon3 blankedJsonToBalancedParens2) [bs]) - , bench "blankedJsonToBalancedParens2" (whnf (runCon3 (blankedJsonToBalancedParens2 =$= rechunk 4060)) [bs]) - ] - ] - benchRechunk :: [Benchmark] benchRechunk = [ env (setupEnvBss 4060 19968) $ \bss -> bgroup "Rank" @@ -88,4 +39,4 @@ ] main :: IO () -main = defaultMain benchRankJson40Conduits +main = defaultMain benchRechunk diff --git a/hw-conduit.cabal b/hw-conduit.cabal --- a/hw-conduit.cabal +++ b/hw-conduit.cabal @@ -1,5 +1,5 @@ name: hw-conduit -version: 0.0.0.10 +version: 0.0.0.11 synopsis: Conduits for tokenizing streams. description: Please see README.md homepage: http://github.com/haskell-works/hw-conduit#readme @@ -25,9 +25,6 @@ library hs-source-dirs: src exposed-modules: HaskellWorks.Data.Conduit.ByteString - , HaskellWorks.Data.Conduit.Json - , HaskellWorks.Data.Conduit.Json.Blank - , HaskellWorks.Data.Conduit.Json.Words , HaskellWorks.Data.Conduit.List build-depends: base >= 4.7 && < 5 , array @@ -45,7 +42,6 @@ hs-source-dirs: test main-is: Spec.hs other-modules: HaskellWorks.Data.Conduit.ByteStringSpec - , HaskellWorks.Data.Conduit.Json.BlankSpec build-depends: base , bytestring , hspec @@ -69,5 +65,4 @@ , criterion , hw-conduit , mmap - , resourcet , vector diff --git a/src/HaskellWorks/Data/Conduit/Json.hs b/src/HaskellWorks/Data/Conduit/Json.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Conduit/Json.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} - -module HaskellWorks.Data.Conduit.Json - ( blankedJsonToInterestBits - , byteStringToBits - , blankedJsonToBalancedParens - , blankedJsonToBalancedParens2 - , compressWordAsBit - , interestingWord8s - ) where - -import Control.Monad -import Data.Array.Unboxed as A -import qualified Data.Bits as BITS -import Data.ByteString as BS -import Data.Conduit -import Data.Int -import Data.Word -import Data.Word8 -import HaskellWorks.Data.Bits.BitWise -import Prelude as P - -interestingWord8s :: A.UArray Word8 Word8 -interestingWord8s = A.array (0, 255) [ - (w, if w == _bracketleft || w == _braceleft || w == _parenleft || w == _t || w == _f || w == _n || w == _1 - then 1 - else 0) - | w <- [0 .. 255]] - -blankedJsonToInterestBits :: Monad m => Conduit BS.ByteString m BS.ByteString -blankedJsonToInterestBits = blankedJsonToInterestBits' "" - -padRight :: Word8 -> Int -> BS.ByteString -> BS.ByteString -padRight w n bs = if BS.length bs >= n then bs else fst (BS.unfoldrN n gen bs) - where gen :: ByteString -> Maybe (Word8, ByteString) - gen cs = case BS.uncons cs of - Just (c, ds) -> Just (c, ds) - Nothing -> Just (w, BS.empty) - -blankedJsonToInterestBits' :: Monad m => BS.ByteString -> Conduit BS.ByteString m BS.ByteString -blankedJsonToInterestBits' rs = do - mbs <- await - case mbs of - Just bs -> do - let cs = if BS.length rs /= 0 then BS.concat [rs, bs] else bs - let lencs = BS.length cs - let q = lencs + 7 `quot` 8 - let (ds, es) = BS.splitAt (q * 8) cs - let (fs, _) = BS.unfoldrN q gen ds - yield fs - blankedJsonToInterestBits' es - Nothing -> return () - where gen :: ByteString -> Maybe (Word8, ByteString) - gen as = if BS.length as == 0 - then Nothing - else Just ( BS.foldr (\b m -> (interestingWord8s ! b) .|. (m .<. 1)) 0 (padRight 0 8 (BS.take 8 as)) - , BS.drop 8 as - ) - -blankedJsonToBalancedParens :: Monad m => Conduit BS.ByteString m Bool -blankedJsonToBalancedParens = do - mbs <- await - case mbs of - Just bs -> blankedJsonToBalancedParens' bs - Nothing -> return () - -blankedJsonToBalancedParens' :: Monad m => BS.ByteString -> Conduit BS.ByteString m Bool -blankedJsonToBalancedParens' bs = case BS.uncons bs of - Just (c, cs) -> do - case c of - d | d == _braceleft -> yield True - d | d == _braceright -> yield False - d | d == _bracketleft -> yield True - d | d == _bracketright -> yield False - d | d == _parenleft -> yield True - d | d == _parenright -> yield False - d | d == _t -> yield True >> yield False - d | d == _f -> yield True >> yield False - d | d == _1 -> yield True >> yield False - d | d == _n -> yield True >> yield False - _ -> return () - blankedJsonToBalancedParens' cs - Nothing -> return () - -compressWordAsBit :: Monad m => Conduit BS.ByteString m BS.ByteString -compressWordAsBit = do - mbs <- await - case mbs of - Just bs -> do - let (cs, _) = BS.unfoldrN (BS.length bs + 7 `div` 8) gen bs - yield cs - Nothing -> return () - where gen :: ByteString -> Maybe (Word8, ByteString) - gen xs = if BS.length xs == 0 - then Nothing - else Just ( BS.foldr (\b m -> ((b .&. 1) .|. (m .<. 1))) 0 (padRight 0 8 (BS.take 8 xs)) - , BS.drop 8 xs - ) - -blankedJsonToBalancedParens2 :: Monad m => Conduit BS.ByteString m BS.ByteString -blankedJsonToBalancedParens2 = do - mbs <- await - case mbs of - Just bs -> do - let (cs, _) = BS.unfoldrN (BS.length bs * 2) gen (Nothing, bs) - yield cs - Nothing -> return () - where gen :: (Maybe Bool, ByteString) -> Maybe (Word8, (Maybe Bool, ByteString)) - gen (Just True , bs) = Just (0xFF, (Nothing, bs)) - gen (Just False , bs) = Just (0x00, (Nothing, bs)) - gen (Nothing , bs) = case BS.uncons bs of - Just (c, cs) -> case balancedParensOf c of - MiniN -> gen (Nothing , cs) - MiniT -> Just (0xFF, (Nothing , cs)) - MiniF -> Just (0x00, (Nothing , cs)) - MiniTF -> Just (0xFF, (Just False , cs)) - Nothing -> Nothing - -data MiniBP = MiniN | MiniT | MiniF | MiniTF - -balancedParensOf :: Word8 -> MiniBP -balancedParensOf c = case c of - d | d == _braceleft -> MiniT - d | d == _braceright -> MiniF - d | d == _bracketleft -> MiniT - d | d == _bracketright -> MiniF - d | d == _parenleft -> MiniT - d | d == _parenright -> MiniF - d | d == _t -> MiniTF - d | d == _f -> MiniTF - d | d == _1 -> MiniTF - d | d == _n -> MiniTF - _ -> MiniN - -yieldBitsOfWord8 :: Monad m => Word8 -> Conduit BS.ByteString m Bool -yieldBitsOfWord8 w = do - yield ((w .&. BITS.bit 0) /= 0) - yield ((w .&. BITS.bit 1) /= 0) - yield ((w .&. BITS.bit 2) /= 0) - yield ((w .&. BITS.bit 3) /= 0) - yield ((w .&. BITS.bit 4) /= 0) - yield ((w .&. BITS.bit 5) /= 0) - yield ((w .&. BITS.bit 6) /= 0) - yield ((w .&. BITS.bit 7) /= 0) - -yieldBitsofWord8s :: Monad m => [Word8] -> Conduit BS.ByteString m Bool -yieldBitsofWord8s = P.foldr ((>>) . yieldBitsOfWord8) (return ()) - -byteStringToBits :: Monad m => Conduit BS.ByteString m Bool -byteStringToBits = do - mbs <- await - case mbs of - Just bs -> yieldBitsofWord8s (BS.unpack bs) >> byteStringToBits - Nothing -> return () diff --git a/src/HaskellWorks/Data/Conduit/Json/Blank.hs b/src/HaskellWorks/Data/Conduit/Json/Blank.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Conduit/Json/Blank.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} - -module HaskellWorks.Data.Conduit.Json.Blank - ( blankJson - ) where - -import Control.Monad -import Control.Monad.Trans.Resource (MonadThrow) -import Data.ByteString as BS -import Data.Conduit -import Data.Word -import Data.Word8 -import HaskellWorks.Data.Conduit.Json.Words -import Prelude as P - -data BlankState - = Escaped - | InJson - | InString - | InNumber - | InIdent - -blankJson :: MonadThrow m => Conduit BS.ByteString m BS.ByteString -blankJson = blankJson' InJson - -blankJson' :: MonadThrow m => BlankState -> Conduit BS.ByteString m BS.ByteString -blankJson' lastState = do - mbs <- await - case mbs of - Just bs -> do - let (!cs, Just (!nextState, _)) = unfoldrN (BS.length bs) blankByteString (lastState, bs) - yield cs - blankJson' nextState - Nothing -> return () - where - blankByteString :: (BlankState, ByteString) -> Maybe (Word8, (BlankState, ByteString)) - blankByteString (InJson, bs) = case BS.uncons bs of - Just (!c, !cs) | isLeadingDigit c -> Just (_1 , (InNumber , cs)) - Just (!c, !cs) | c == _quotedbl -> Just (_parenleft , (InString , cs)) - Just (!c, !cs) | isAlphabetic c -> Just (c , (InIdent , cs)) - Just (!c, !cs) -> Just (c , (InJson , cs)) - Nothing -> Nothing - blankByteString (InString, bs) = case BS.uncons bs of - Just (!c, !cs) | c == _backslash -> Just (_space , (Escaped , cs)) - Just (!c, !cs) | c == _quotedbl -> Just (_parenright , (InJson , cs)) - Just (_ , !cs) -> Just (_space , (InString , cs)) - Nothing -> Nothing - blankByteString (Escaped, bs) = case BS.uncons bs of - Just (_, !cs) -> Just (_space, (InString, cs)) - Nothing -> Nothing - blankByteString (InNumber, bs) = case BS.uncons bs of - Just (!c, !cs) | isTrailingDigit c -> Just (_0 , (InNumber , cs)) - Just (!c, !cs) | c == _quotedbl -> Just (_parenleft , (InString , cs)) - Just (!c, !cs) | isAlphabetic c -> Just (c , (InIdent , cs)) - Just (!c, !cs) -> Just (c , (InJson , cs)) - Nothing -> Nothing - blankByteString (InIdent, bs) = case BS.uncons bs of - Just (!c, !cs) | isAlphabetic c -> Just (_underscore , (InIdent , cs)) - Just (!c, !cs) | isLeadingDigit c -> Just (_1 , (InNumber , cs)) - Just (!c, !cs) | c == _quotedbl -> Just (_parenleft , (InString , cs)) - Just (!c, !cs) -> Just (c , (InJson , cs)) - Nothing -> Nothing diff --git a/src/HaskellWorks/Data/Conduit/Json/Words.hs b/src/HaskellWorks/Data/Conduit/Json/Words.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Conduit/Json/Words.hs +++ /dev/null @@ -1,13 +0,0 @@ -module HaskellWorks.Data.Conduit.Json.Words where - -import Data.Word -import Data.Word8 - -isLeadingDigit :: Word8 -> Bool -isLeadingDigit w = w == _hyphen || (w >= _0 && w <= _9) - -isTrailingDigit :: Word8 -> Bool -isTrailingDigit w = w == _plus || w == _hyphen || (w >= _0 && w <= _9) || w == _period || w == _E || w == _e - -isAlphabetic :: Word8 -> Bool -isAlphabetic w = (w >= _A && w <= _Z) || (w >= _a && w <= _z) diff --git a/test/HaskellWorks/Data/Conduit/Json/BlankSpec.hs b/test/HaskellWorks/Data/Conduit/Json/BlankSpec.hs deleted file mode 100644 --- a/test/HaskellWorks/Data/Conduit/Json/BlankSpec.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module HaskellWorks.Data.Conduit.Json.BlankSpec (spec) where - -import qualified Data.ByteString as BS -import HaskellWorks.Data.Conduit.Json.Blank -import HaskellWorks.Data.Conduit.List -import Test.Hspec - -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} - -whenBlankedJsonShouldBe :: BS.ByteString -> BS.ByteString -> Spec -whenBlankedJsonShouldBe original expected = do - it (show original ++ " when blanked json should be " ++ show expected) $ do - BS.concat (runListConduit blankJson [original]) `shouldBe` expected - -spec :: Spec -spec = describe "HaskellWorks.Data.Conduit.Json.BlankSpec" $ do - describe "Can blank json" $ do - "\"\"" `whenBlankedJsonShouldBe` "()" - "\"\\\\\"" `whenBlankedJsonShouldBe` "( )" - "\"\\\\\\\"" `whenBlankedJsonShouldBe` "( " - "\" \\\\\\\"" `whenBlankedJsonShouldBe` "( " - "\" \\n\\\\\"" `whenBlankedJsonShouldBe` "( )" - "" `whenBlankedJsonShouldBe` "" - "\"\"" `whenBlankedJsonShouldBe` "()" - "\" \"" `whenBlankedJsonShouldBe` "( )" - "\" a \"" `whenBlankedJsonShouldBe` "( )" - " \"a \" x" `whenBlankedJsonShouldBe` " ( ) x" - " \"a\"b\"c\"d" `whenBlankedJsonShouldBe` " ( )b( )d" - "" `whenBlankedJsonShouldBe` "" - "1" `whenBlankedJsonShouldBe` "1" - "11" `whenBlankedJsonShouldBe` "10" - "00" `whenBlankedJsonShouldBe` "10" - "00" `whenBlankedJsonShouldBe` "10" - "-0.12e+34" `whenBlankedJsonShouldBe` "100000000" - "10.12E-34 " `whenBlankedJsonShouldBe` "100000000 " - "10.12E-34 12" `whenBlankedJsonShouldBe` "100000000 10" - " 10.12E-34 -1" `whenBlankedJsonShouldBe` " 100000000 10" - "" `whenBlankedJsonShouldBe` "" - "a" `whenBlankedJsonShouldBe` "a" - "z" `whenBlankedJsonShouldBe` "z" - " Aaa " `whenBlankedJsonShouldBe` " A__ " - " Za def " `whenBlankedJsonShouldBe` " Z_ d__ " - "" `whenBlankedJsonShouldBe` "" - " { \"ff\": 1.0, [\"\", true], null}" `whenBlankedJsonShouldBe` " { ( ): 100, [(), t___], n___}"