diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -4,13 +4,18 @@ module Main where import Criterion.Main +import Control.Monad.Trans.Resource (MonadThrow) import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BSI +import Data.Conduit import qualified Data.Vector.Storable as DVS import Data.Word import Foreign import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Conduit.List import HaskellWorks.Data.FromByteString +import HaskellWorks.Data.Json.Conduit +import HaskellWorks.Data.Json.Conduit.Blank import HaskellWorks.Data.Json.Succinct.Cursor import HaskellWorks.Data.Positioning import HaskellWorks.Data.Succinct.BalancedParens.Simple @@ -47,31 +52,50 @@ ] ] +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 "loadJson " (whnf loadJson bs) + [ bench "Run blankJson " (whnf (runCon blankJson ) bs) + , bench "Run jsonToInterestBits3 " (whnf (runCon jsonToInterestBits3 ) bs) + , bench "loadJson " (whnf loadJson bs) ] ] benchRankJson80Conduits :: [Benchmark] benchRankJson80Conduits = [ env (setupEnvJson "/Users/jky/Downloads/part80.json") $ \bs -> bgroup "Json40" - [ bench "loadJson" (whnf loadJson bs) + [ bench "Run blankJson " (whnf (runCon blankJson ) bs) + , bench "Run jsonToInterestBits3 " (whnf (runCon jsonToInterestBits3 ) bs) + , bench "loadJson" (whnf loadJson bs) ] ] benchRankJsonBigConduits :: [Benchmark] benchRankJsonBigConduits = [ env (setupEnvJson "/Users/jky/Downloads/78mb.json") $ \bs -> bgroup "JsonBig" - [ bench "loadJson" (whnf loadJson bs) + [ bench "Run blankJson " (whnf (runCon blankJson ) bs) + , bench "Run jsonToInterestBits3 " (whnf (runCon jsonToInterestBits3 ) bs) + , bench "loadJson" (whnf loadJson bs) ] ] benchBlankedJsonToBalancedParens :: [Benchmark] benchBlankedJsonToBalancedParens = [ env (setupEnvJson "/Users/jky/Downloads/part40.json") $ \bs -> bgroup "JsonBig" - [ bench "loadJson" (whnf loadJson bs) + [ bench "blankedJsonToBalancedParens2" (whnf (runCon2 blankedJsonToBalancedParens) [bs]) + , bench "blankedJsonToBalancedParens2" (whnf (runCon3 blankedJsonToBalancedParens2) [bs]) ] ] diff --git a/hw-json.cabal b/hw-json.cabal --- a/hw-json.cabal +++ b/hw-json.cabal @@ -1,5 +1,5 @@ name: hw-json -version: 0.0.0.1 +version: 0.0.0.2 synopsis: Conduits for tokenizing streams. description: Please see README.md homepage: http://github.com/haskell-works/hw-json#readme @@ -36,6 +36,9 @@ library hs-source-dirs: src exposed-modules: HaskellWorks.Data.Json + , HaskellWorks.Data.Json.Conduit + , HaskellWorks.Data.Json.Conduit.Blank + , HaskellWorks.Data.Json.Conduit.Words , HaskellWorks.Data.Json.Extract , HaskellWorks.Data.Json.Succinct , HaskellWorks.Data.Json.Succinct.Cursor @@ -52,6 +55,7 @@ , HaskellWorks.Data.Json.Type , HaskellWorks.Data.Json.Value build-depends: base >= 4.7 && < 5 + , array , attoparsec , bytestring , conduit @@ -62,6 +66,7 @@ , hw-prim , hw-rankselect , mono-traversable + , resourcet , text , vector , word8 @@ -110,6 +115,7 @@ , conduit , criterion , hw-bits + , hw-conduit , hw-json , hw-prim , hw-rankselect diff --git a/src/HaskellWorks/Data/Json/Conduit.hs b/src/HaskellWorks/Data/Json/Conduit.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Conduit.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module HaskellWorks.Data.Json.Conduit + ( 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/Json/Conduit/Blank.hs b/src/HaskellWorks/Data/Json/Conduit/Blank.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Conduit/Blank.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module HaskellWorks.Data.Json.Conduit.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.Json.Conduit.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/Json/Conduit/Words.hs b/src/HaskellWorks/Data/Json/Conduit/Words.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Conduit/Words.hs @@ -0,0 +1,13 @@ +module HaskellWorks.Data.Json.Conduit.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/src/HaskellWorks/Data/Json/Extract.hs b/src/HaskellWorks/Data/Json/Extract.hs --- a/src/HaskellWorks/Data/Json/Extract.hs +++ b/src/HaskellWorks/Data/Json/Extract.hs @@ -6,7 +6,7 @@ import qualified Data.ByteString as BS import Data.Word8 -import HaskellWorks.Data.Conduit.Json.Words +import HaskellWorks.Data.Json.Conduit.Words import HaskellWorks.Data.Json.Type data ExtractJsonState diff --git a/src/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParens.hs b/src/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParens.hs --- a/src/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParens.hs +++ b/src/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParens.hs @@ -13,8 +13,8 @@ import Data.Conduit import qualified Data.Vector.Storable as DVS import Data.Word -import HaskellWorks.Data.Conduit.Json import HaskellWorks.Data.Conduit.List +import HaskellWorks.Data.Json.Conduit import HaskellWorks.Data.Json.Succinct.Cursor.BlankedJson import HaskellWorks.Data.Succinct.BalancedParens as BP diff --git a/src/HaskellWorks/Data/Json/Succinct/Cursor/BlankedJson.hs b/src/HaskellWorks/Data/Json/Succinct/Cursor/BlankedJson.hs --- a/src/HaskellWorks/Data/Json/Succinct/Cursor/BlankedJson.hs +++ b/src/HaskellWorks/Data/Json/Succinct/Cursor/BlankedJson.hs @@ -7,9 +7,9 @@ import qualified Data.ByteString as BS import HaskellWorks.Data.ByteString -import HaskellWorks.Data.Conduit.Json.Blank import HaskellWorks.Data.Conduit.List import HaskellWorks.Data.FromByteString +import HaskellWorks.Data.Json.Conduit.Blank newtype BlankedJson = BlankedJson [BS.ByteString] deriving (Eq, Show) diff --git a/src/HaskellWorks/Data/Json/Succinct/Cursor/InterestBits.hs b/src/HaskellWorks/Data/Json/Succinct/Cursor/InterestBits.hs --- a/src/HaskellWorks/Data/Json/Succinct/Cursor/InterestBits.hs +++ b/src/HaskellWorks/Data/Json/Succinct/Cursor/InterestBits.hs @@ -14,9 +14,9 @@ import qualified Data.Vector.Storable as DVS import Data.Word import HaskellWorks.Data.Bits.BitShown -import HaskellWorks.Data.Conduit.Json import HaskellWorks.Data.Conduit.List import HaskellWorks.Data.FromByteString +import HaskellWorks.Data.Json.Conduit import HaskellWorks.Data.Json.Succinct.Cursor.BlankedJson import HaskellWorks.Data.Succinct.RankSelect.Binary.Poppy512