diff --git a/corpus/5000B.bp b/corpus/5000B.bp new file mode 100644 --- /dev/null +++ b/corpus/5000B.bp @@ -0,0 +1,1 @@ +111011010010101010101010101010101010101010101010101010101010101010101010101010101010110100101010101011011110100100111010010011101001000010111010101001101010100010111010101010110101010101000110101010101101010101010001101010101011010101010100011010101010110101010101000110101010101101010101010001101010101011010101010100011010101010110101010101000110101010101101010101010001101010101011010101010100011010101010110101010101000110101010101101010101010001101010101011010101010100011010101010110101010101000110101010101101010101010001101010101011010101010100011010101010110101010101000110101010101101010101010000101110110101010001101101010100011011010101000110110101010001101101010100011011010101000000 diff --git a/corpus/5000B.ib b/corpus/5000B.ib new file mode 100644 --- /dev/null +++ b/corpus/5000B.ib @@ -0,0 +1,1 @@ +10101000000010100000000100000000000000000000000000000100000000100000000000100000000000001000000010000000000000000001000000000000000000000000000000000000000000000100000000000000001000000000000000000000000001000000000000100000000000000000000000000000010000000000000000010000000000000000000000000000000000010000000000000000000010000000000000000001000000000000000001000000100000000000000000000000100010000000000000000100000100000000000000000100010000000000000001000100000000000000000001001000000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000001000000000000001000100000000000000000100000000000000000000100000000000000001000000000000000100000000000000010000000000000000000000000000001000000000000001010000000001000000000000000010000000000000010000000000000000000000000000000100000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000000001010000000000000000000101010100001000001000000000000000000000000000000000000000000000000000000000000101010000100000010000000000000000000000000000000000000000000000000000000000001010100001000000100000000000000000000000000000000000000000000000000000000000000001000000000000101010000000010000000000000000000100000000000001000000000000000000101000000001000000000000000000000000000000000000001000000000000010000000000000000000000000000000000000000001000000000000000001010100000000000100000010000000001000000000000000000000000000000000000000000000000000001000000000010100000000000000100000000001000000000000010000000001000000000000010000000000000000000001010000000000010000001000000000100000000000000000000000000000000000010000000000101000000000000001000000100000000000001000000000010000000000000100000000000000000010100000000000100000010000000001000000000000000000000000010000000000101000000000000001000000100000000000001000000001000000000000010000000000000000101000000000001000000100000000010000000000000000000000000000000000000000010000000000101000000000000001000000001000000000000010000000001000000000000010000000000000000000101000000000001000000100000000010000000010000000000101000000000000001000000000001000000000000010000000000010000000000000100000000000000000000000010100000000000100000010000000001000000000000000100000000001010000000000000010000001000000000000010000001000000000000010000000000000010100000000000100000010000000001000000001000000000010100000000000000100000010000000000000100000000010000000000000100000000000000000101000000000001000000100000000010000000000000000000000000000000001000000000010100000000000000100000001000000000000010000000000001000000000000010000000000000000000001010000000000010000010000000001000000100000000001010000000000000010000000100000000000001000000001000000000000010000000000000000010100000000000100000100000000010000000000010000000000101000000000000001000000001000000000000010000000000100000000000001000000000000000000001010000000000010000010000000001000000000000000000000000000000000001000000000010100000000000000100000010000000000000100000000100000000000001000000000000000010100000000000100000100000000010000000000000000000000000000010000000000101000000000000001000000000100000000000001000000001000000000000010000000000000000000101000000000001000001000000000100000000000000010000000000101000000000000001000000001000000000000010000000000010000000000000100000000000000000000010100000000000100000100000000010000000000000000000001000000000010100000000000000100000001000000000000010000000100000000000001000000000000000010100000000000100000100000000010000000000000000010000000000101000000000000001000000001000000000000010000000000100000000000001000000000000000000001010000000000010000010000000001000000000000000000010000000000101000000000000001000000001000000000000010000000000100000000000001000000000000000000001010000000000010000010000000001000000000000000000000000001000000000010100000000000000100000000100000000000001000000000100000000000001000000000000000000000100000000000000001010100000000000000101000000001000000001000000000000010000000000001010000000000000010100000000100000000001000000000000010000000000000010100000000000000101000000001000000000000010000000000000100000000000000000101000000000000001010000000010000000000000000000001000000000000010000000000010100000000000000101000000001000000000100000000000001000000000000010100000000000000101000001000010000100000 diff --git a/corpus/5000B.json b/corpus/5000B.json new file mode 100644 --- /dev/null +++ b/corpus/5000B.json @@ -0,0 +1,1 @@ +[ { "_id" : { "$oid" : "52cdef7c4bab8bd675297d8a" }, "name" : "Wetpaint", "permalink" : "abc2", "crunchbase_url" : "http://www.crunchbase.com/company/wetpaint", "homepage_url" : "http://wetpaint-inc.com", "blog_url" : "http://digitalquarters.net/", "blog_feed_url" : "http://digitalquarters.net/feed/", "twitter_username" : "BachelrWetpaint", "category_code" : "web", "number_of_employees" : 47, "founded_year" : 2005, "founded_month" : 10, "founded_day" : 17, "deadpooled_year" : 1, "tag_list" : "wiki, seattle, elowitz, media-industry, media-platform, social-distribution-system", "alias_list" : "", "email_address" : "info@wetpaint.com", "phone_number" : "206.859.6300", "description" : "Technology Platform Company", "created_at" : { "$date" : 1180075887000 }, "updated_at" : "Sun Dec 08 07:15:44 UTC 2013", "overview" : "

Wetpaint is a technology platform company that uses its proprietary state-of-the-art technology and expertise in social media to build and monetize audiences for digital publishers. Wetpaint's own online property, Wetpaint Entertainment, an entertainment news site that attracts more than 12 million unique visitors monthly and has over 2 million Facebook fans, is a proof point to the company's success in building and engaging audiences. Media companies can license Wetpaint's platform which includes a dynamic playbook tailored to their individual needs and comprehensive training. Founded by Internet pioneer Ben Elowitz, and with offices in New York and Seattle, Wetpaint is backed by Accel Partners, the investors behind Facebook.

", "image" : { "available_sizes" : [ [ [ 150, 75 ], "assets/images/resized/0000/3604/3604v14-max-150x150.jpg" ], [ [ 250, 125 ], "assets/images/resized/0000/3604/3604v14-max-250x250.jpg" ], [ [ 450, 225 ], "assets/images/resized/0000/3604/3604v14-max-450x450.jpg" ] ] }, "products" : [ { "name" : "Wikison Wetpaint", "permalink" : "wetpaint-wiki" }, { "name" : "Wetpaint Social Distribution System", "permalink" : "wetpaint-social-distribution-system" } ], "relationships" : [ { "is_past" : false, "title" : "Co-Founder and VP, Social and Audience Development", "person" : { "first_name" : "Michael", "last_name" : "Howell", "permalink" : "michael-howell" } }, { "is_past" : false, "title" : "Co-Founder/CEO/Board of Directors", "person" : { "first_name" : "Ben", "last_name" : "Elowitz", "permalink" : "ben-elowitz" } }, { "is_past" : false, "title" : "COO/Board of Directors", "person" : { "first_name" : "Rob", "last_name" : "Grady", "permalink" : "rob-grady" } }, { "is_past" : false, "title" : "SVP, Strategy and Business Development", "person" : { "first_name" : "Chris", "last_name" : "Kollas", "permalink" : "chris-kollas" } }, { "is_past" : false, "title" : "Board", "person" : { "first_name" : "Theresia", "last_name" : "Ranzetta", "permalink" : "theresia-ranzetta" } }, { "is_past" : false, "title" : "Board Member", "person" : { "first_name" : "Gus", "last_name" : "Tai", "permalink" : "gus-tai" } }, { "is_past" : false, "title" : "Board", "person" : { "first_name" : "Len", "last_name" : "Jordan", "permalink" : "len-jordan" } }, { "is_past" : false, "title" : "Head of Technology and Product", "person" : { "first_name" : "Alex", "last_name" : "Weinstein", "permalink" : "alex-weinstein" } }, { "is_past" : true, "title" : "CFO", "person" : { "first_name" : "Bert", "last_name" : "Hogue", "permalink" : "bert-hogue" } }, { "is_past" : true, "title" : "CFO/ CRO", "person" : { "first_name" : "Brian", "last_name" : "Watkins", "permalink" : "brian-watkins" } }, { "is_past" : true, "title" : "Senior Vice President, Marketing", "person" : { "first_name" : "Rob", "last_name" : "Grady", "permalink" : "rob-grady" } }, { "is_past" : true, "title" : "VP, Technology and Product", "person" : { "first_name" : "Werner", "last_name" : "Koepf", "permalink" : "werner-koepf" } }, { "is_past" : true, "title" : "VP Marketing", "person" : { "first_name" : "Kevin", "last_name" : "Flaherty", "permalink" : "kevin-flaherty" } }, { "is_past" : true, "title" : "VP User Experience", "person" : { "first_name" : "Alex", "last_name" : "Berg", "permalink" : "alex-berg" } }, { "is_past" : true, "title" : "VP Engineering", "person" : { "first_name" : "Steve", "last_name" : "McQuade", "permalink" : "steve-mcquade" } }, { "is_past" : true, "title" : "Executive Editor", "person" : { "first_name" : "Susan", "last_name" : "Mulcahy", "permalink" : "susan-mulcahy" } }, { "is_past" : true, "title" : "VP Business Development", "person" : { "first_name" : "Chris", "last_name" : "Kollas", "permalink" : "chris-kollas" } } ], "competitions" : [ { "competitor" : { "name" : "Wikia", "permalink" : "wikia" } }, { "competitor" : { "name" : "JotSpot", "permalink" : "jotspot" } }, { "competitor" : { "name" : "Socialtext", "permalink" : "socialtext" } }, { "competitor" : { "name" : "Ning by Glam Media", "permalink" : "ning" } }, { "competitor" : { "name" : "Soceeo", "permalink" : "soceeo" } }, { "competitor" : { "n" : "Y", "" : 1234567}}]}] 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.2.0.0 +version: 0.2.0.1 synopsis: Conduits for tokenizing streams. description: Please see README.md homepage: http://github.com/haskell-works/hw-json#readme @@ -10,7 +10,10 @@ copyright: 2016 John Ky category: Data, Conduit build-type: Simple -extra-source-files: README.md +extra-source-files: README.md, + corpus/5000B.bp, + corpus/5000B.ib, + corpus/5000B.json cabal-version: >= 1.22 executable hw-json-example @@ -41,6 +44,7 @@ , HaskellWorks.Data.Json.Conduit.Blank , HaskellWorks.Data.Json.Conduit.Words , HaskellWorks.Data.Json.FromValue + , HaskellWorks.Data.Json.PartialValue , HaskellWorks.Data.Json.Succinct , HaskellWorks.Data.Json.Succinct.Cursor , HaskellWorks.Data.Json.Succinct.Cursor.BalancedParens @@ -49,6 +53,7 @@ , HaskellWorks.Data.Json.Succinct.Cursor.Internal , HaskellWorks.Data.Json.Succinct.Cursor.Token , HaskellWorks.Data.Json.Succinct.Index + , HaskellWorks.Data.Json.Succinct.PartialIndex , HaskellWorks.Data.Json.Token.Tokenize , HaskellWorks.Data.Json.Token.Types , HaskellWorks.Data.Json.Token @@ -81,9 +86,11 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs - other-modules: HaskellWorks.Data.Json.Token.TokenizeSpec - , HaskellWorks.Data.Json.Succinct.CursorSpec + other-modules: HaskellWorks.Data.Json.CorpusSpec + , HaskellWorks.Data.Json.Succinct.Cursor.BalancedParensSpec , HaskellWorks.Data.Json.Succinct.Cursor.InterestBitsSpec + , HaskellWorks.Data.Json.Succinct.CursorSpec + , HaskellWorks.Data.Json.Token.TokenizeSpec , HaskellWorks.Data.Json.TypeSpec , HaskellWorks.Data.Json.ValueSpec build-depends: base >= 4 && < 5 diff --git a/src/HaskellWorks/Data/Json/Conduit.hs b/src/HaskellWorks/Data/Json/Conduit.hs --- a/src/HaskellWorks/Data/Json/Conduit.hs +++ b/src/HaskellWorks/Data/Json/Conduit.hs @@ -83,14 +83,27 @@ blankedJsonToBalancedParens' cs Nothing -> return () +repartitionMod8 :: BS.ByteString -> BS.ByteString -> (BS.ByteString, BS.ByteString) +repartitionMod8 aBS bBS = (BS.take cLen abBS, BS.drop cLen abBS) + where abBS = BS.concat [aBS, bBS] + abLen = BS.length abBS + cLen = (abLen `div` 8) * 8 + 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 +compressWordAsBit = compressWordAsBit' BS.empty + +compressWordAsBit' :: Monad m => BS.ByteString -> Conduit BS.ByteString m BS.ByteString +compressWordAsBit' aBS = do + mbBS <- await + case mbBS of + Just bBS -> do + let (cBS, dBS) = repartitionMod8 aBS bBS + let (cs, _) = BS.unfoldrN (BS.length cBS + 7 `div` 8) gen cBS yield cs - Nothing -> return () + compressWordAsBit' dBS + Nothing -> do + let (cs, _) = BS.unfoldrN (BS.length aBS + 7 `div` 8) gen aBS + yield cs where gen :: ByteString -> Maybe (Word8, ByteString) gen xs = if BS.length xs == 0 then Nothing @@ -105,13 +118,14 @@ Just bs -> do let (cs, _) = BS.unfoldrN (BS.length bs * 2) gen (Nothing, bs) yield cs + blankedJsonToBalancedParens2 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) + MiniN -> gen (Nothing , cs) MiniT -> Just (0xFF, (Nothing , cs)) MiniF -> Just (0x00, (Nothing , cs)) MiniTF -> Just (0xFF, (Just False , cs)) diff --git a/src/HaskellWorks/Data/Json/PartialValue.hs b/src/HaskellWorks/Data/Json/PartialValue.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/PartialValue.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module HaskellWorks.Data.Json.PartialValue + ( JsonPartialValue(..) + , JsonPartialValueAt(..) + ) where + +import Control.Arrow +import qualified Data.Attoparsec.ByteString.Char8 as ABC +import qualified Data.ByteString as BS +import HaskellWorks.Data.Json.Succinct.PartialIndex +import HaskellWorks.Data.Json.Value.Internal + +data JsonPartialValue + = JsonPartialString String + | JsonPartialNumber Double + | JsonPartialObject [(String, JsonPartialValue)] + | JsonPartialArray [JsonPartialValue] + | JsonPartialBool Bool + | JsonPartialNull + | JsonPartialError String + deriving (Eq, Show) + +class JsonPartialValueAt a where + jsonPartialJsonValueAt :: a -> JsonPartialValue + +asString :: JsonPartialValue -> String +asString pjv = case pjv of + JsonPartialString s -> s + _ -> "" + +instance JsonPartialValueAt JsonPartialIndex where + jsonPartialJsonValueAt i = case i of + JsonPartialIndexString s -> case ABC.parse parseJsonString s of + ABC.Fail {} -> JsonPartialError ("Invalid string: '" ++ show (BS.take 20 s) ++ "...'") + ABC.Partial _ -> JsonPartialError "Unexpected end of string" + ABC.Done _ r -> JsonPartialString r + JsonPartialIndexNumber s -> case ABC.parse ABC.rational s of + ABC.Fail {} -> JsonPartialError ("Invalid number: '" ++ show (BS.take 20 s) ++ "...'") + ABC.Partial f -> case f " " of + ABC.Fail {} -> JsonPartialError ("Invalid number: '" ++ show (BS.take 20 s) ++ "...'") + ABC.Partial _ -> JsonPartialError "Unexpected end of number" + ABC.Done _ r -> JsonPartialNumber r + ABC.Done _ r -> JsonPartialNumber r + JsonPartialIndexObject fs -> JsonPartialObject (map ((asString . parseString) *** jsonPartialJsonValueAt) fs) + JsonPartialIndexArray es -> JsonPartialArray (map jsonPartialJsonValueAt es) + JsonPartialIndexBool v -> JsonPartialBool v + JsonPartialIndexNull -> JsonPartialNull + JsonPartialIndexError s -> JsonPartialError s + where parseString bs = case ABC.parse parseJsonString bs of + ABC.Fail {} -> JsonPartialError ("Invalid field: '" ++ show (BS.take 20 bs) ++ "...'") + ABC.Partial _ -> JsonPartialError "Unexpected end of field" + ABC.Done _ s -> JsonPartialString s 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 @@ -31,21 +31,21 @@ fromBlankedJson (BlankedJson bj) = JsonBalancedParens (SimpleBalancedParens (runListConduit blankedJsonToBalancedParens bj)) instance FromBlankedJson (JsonBalancedParens (SimpleBalancedParens (DVS.Vector Word8))) where - fromBlankedJson bj = JsonBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever interestBS))) - where interestBS = BS.concat (runListConduit (blankedJsonToBalancedParens2 =$= compressWordAsBit) (getBlankedJson bj)) - newLen = (BS.length interestBS + 7) `div` 8 * 8 + fromBlankedJson bj = JsonBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever bpBS))) + where bpBS = BS.concat (runListConduit (blankedJsonToBalancedParens2 =$= compressWordAsBit) (getBlankedJson bj)) + newLen = (BS.length bpBS + 7) `div` 8 * 8 instance FromBlankedJson (JsonBalancedParens (SimpleBalancedParens (DVS.Vector Word16))) where - fromBlankedJson bj = JsonBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever interestBS))) - where interestBS = BS.concat (runListConduit (blankedJsonToBalancedParens2 =$= compressWordAsBit) (getBlankedJson bj)) - newLen = (BS.length interestBS + 7) `div` 8 * 8 + fromBlankedJson bj = JsonBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever bpBS))) + where bpBS = BS.concat (runListConduit (blankedJsonToBalancedParens2 =$= compressWordAsBit) (getBlankedJson bj)) + newLen = (BS.length bpBS + 7) `div` 8 * 8 instance FromBlankedJson (JsonBalancedParens (SimpleBalancedParens (DVS.Vector Word32))) where - fromBlankedJson bj = JsonBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever interestBS))) - where interestBS = BS.concat (runListConduit (blankedJsonToBalancedParens2 =$= compressWordAsBit) (getBlankedJson bj)) - newLen = (BS.length interestBS + 7) `div` 8 * 8 + fromBlankedJson bj = JsonBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever bpBS))) + where bpBS = BS.concat (runListConduit (blankedJsonToBalancedParens2 =$= compressWordAsBit) (getBlankedJson bj)) + newLen = (BS.length bpBS + 7) `div` 8 * 8 instance FromBlankedJson (JsonBalancedParens (SimpleBalancedParens (DVS.Vector Word64))) where - fromBlankedJson bj = JsonBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever interestBS))) - where interestBS = BS.concat (runListConduit (blankedJsonToBalancedParens2 =$= compressWordAsBit) (getBlankedJson bj)) - newLen = (BS.length interestBS + 7) `div` 8 * 8 + fromBlankedJson bj = JsonBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever bpBS))) + where bpBS = BS.concat (runListConduit (blankedJsonToBalancedParens2 =$= compressWordAsBit) (getBlankedJson bj)) + newLen = (BS.length bpBS + 7) `div` 8 * 8 diff --git a/src/HaskellWorks/Data/Json/Succinct/Cursor/Internal.hs b/src/HaskellWorks/Data/Json/Succinct/Cursor/Internal.hs --- a/src/HaskellWorks/Data/Json/Succinct/Cursor/Internal.hs +++ b/src/HaskellWorks/Data/Json/Succinct/Cursor/Internal.hs @@ -29,7 +29,6 @@ import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select1 import HaskellWorks.Data.Succinct.RankSelect.Binary.Poppy512 import HaskellWorks.Data.TreeCursor -import HaskellWorks.Data.Vector.VectorLike data JsonCursor t v w = JsonCursor { cursorText :: !t @@ -107,7 +106,7 @@ subtreeSize :: JsonCursor t v u -> Maybe Count subtreeSize k = BP.subtreeSize (balancedParens k) (cursorRank k) -jsonCursorPos :: (Rank1 w, Select1 v, VectorLike s) => JsonCursor s v w -> Position +jsonCursorPos :: (Rank1 w, Select1 v) => JsonCursor s v w -> Position jsonCursorPos k = toPosition (select1 ik (rank1 bpk (cursorRank k)) - 1) where ik = interests k bpk = balancedParens k diff --git a/src/HaskellWorks/Data/Json/Succinct/PartialIndex.hs b/src/HaskellWorks/Data/Json/Succinct/PartialIndex.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Succinct/PartialIndex.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.Json.Succinct.PartialIndex where + +import Control.Arrow +import qualified Data.ByteString as BS +import qualified Data.List as L +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Json.CharLike +import HaskellWorks.Data.Json.Succinct +import HaskellWorks.Data.Positioning +import qualified HaskellWorks.Data.Succinct.BalancedParens as BP +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank0 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank1 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select1 +import HaskellWorks.Data.TreeCursor +import HaskellWorks.Data.Vector.VectorLike + +data JsonPartialIndex + = JsonPartialIndexString BS.ByteString + | JsonPartialIndexNumber BS.ByteString + | JsonPartialIndexObject [(BS.ByteString, JsonPartialIndex)] + | JsonPartialIndexArray [JsonPartialIndex] + | JsonPartialIndexBool Bool + | JsonPartialIndexNull + | JsonPartialIndexError String + deriving (Eq, Show) + +class JsonPartialIndexAt a where + jsonPartialIndexAt :: a -> JsonPartialIndex + +instance (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => JsonPartialIndexAt (JsonCursor BS.ByteString v w) where + jsonPartialIndexAt k = case vUncons remainder of + Just (!c, _) | isLeadingDigit2 c -> JsonPartialIndexNumber remainder + Just (!c, _) | isQuotDbl c -> JsonPartialIndexString remainder + Just (!c, _) | isChar_t c -> JsonPartialIndexBool True + Just (!c, _) | isChar_f c -> JsonPartialIndexBool False + Just (!c, _) | isChar_n c -> JsonPartialIndexNull + Just (!c, _) | isBraceLeft c -> JsonPartialIndexObject (mapValuesFrom (firstChild k)) + Just (!c, _) | isBracketLeft c -> JsonPartialIndexArray (arrayValuesFrom (firstChild k)) + Just _ -> JsonPartialIndexError "Invalid Json Type" + Nothing -> JsonPartialIndexError "End of data" + where ik = interests k + bpk = balancedParens k + p = lastPositionOf (select1 ik (rank1 bpk (cursorRank k))) + remainder = vDrop (toCount p) (cursorText k) + arrayValuesFrom :: Maybe (JsonCursor BS.ByteString v w) -> [JsonPartialIndex] + arrayValuesFrom = L.unfoldr (fmap (jsonPartialIndexAt &&& nextSibling)) + mapValuesFrom j = pairwise (arrayValuesFrom j) >>= asField + pairwise (a:b:rs) = (a, b) : pairwise rs + pairwise _ = [] + asField (a, b) = case a of + JsonPartialIndexString s -> [(s, b)] + _ -> [] diff --git a/test/HaskellWorks/Data/Json/CorpusSpec.hs b/test/HaskellWorks/Data/Json/CorpusSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Json/CorpusSpec.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module HaskellWorks.Data.Json.CorpusSpec(spec) where + +import Control.Monad +import qualified Data.ByteString as BS +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Bits.FromBitTextByteString +import HaskellWorks.Data.Json.Succinct.Cursor as C +import HaskellWorks.Data.Succinct.BalancedParens.Simple +import HaskellWorks.Data.Vector.VectorLike +import Test.Hspec +import HaskellWorks.Data.Bits + +import HaskellWorks.Data.FromByteString + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} +{-# ANN module ("HLint: redundant bracket" :: String) #-} + +spec :: Spec +spec = describe "HaskellWorks.Data.Json.Corpus" $ do + it "Corpus 5000B loads properly" $ do + inJsonBS <- BS.readFile "corpus/5000B.json" + inInterestBitsBS <- BS.readFile "corpus/5000B.ib" + inInterestBalancedParensBS <- BS.readFile "corpus/5000B.bp" + let inInterestBits = fromBitTextByteString inInterestBitsBS + let inInterestBalancedParens = fromBitTextByteString inInterestBalancedParensBS + let !cursor = fromByteString inJsonBS :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) + let text = cursorText cursor + let ib = interests cursor + let SimpleBalancedParens bp = balancedParens cursor + text `shouldBe` inJsonBS + ib `shouldBe` BitShown inInterestBits + bp `shouldBe` inInterestBalancedParens + it "issue-0001 loads properly" $ do + inJsonBS <- BS.readFile "corpus/issue-0001.json" + inInterestBitsBS <- BS.readFile "corpus/issue-0001.ib" + inInterestBalancedParensBS <- BS.readFile "corpus/issue-0001.bp" + let inInterestBits = fromBitTextByteString inInterestBitsBS + let inInterestBalancedParens = fromBitTextByteString inInterestBalancedParensBS + let !cursor = fromByteString inJsonBS :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) + let text = cursorText cursor + let ib = interests cursor + let SimpleBalancedParens bp = balancedParens cursor + text `shouldBe` inJsonBS + ib `shouldBe` BitShown inInterestBits + bp `shouldBe` inInterestBalancedParens diff --git a/test/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParensSpec.hs b/test/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParensSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParensSpec.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module HaskellWorks.Data.Json.Succinct.Cursor.BalancedParensSpec(spec) where + +import qualified Data.ByteString as BS +import Data.Conduit +import Data.String +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Conduit.List +import HaskellWorks.Data.Json.Conduit +import HaskellWorks.Data.Json.Succinct.Cursor.BlankedJson +import Test.Hspec + +{-# ANN module ("HLint: Ignore Redundant do" :: String) #-} + +spec :: Spec +spec = describe "HaskellWorks.Data.Json.Succinct.Cursor.BalancedParensSpec" $ do + it "Blanking JSON should not contain strange characters 1" $ do + let blankedJson = BlankedJson ["[ [],", "[]]"] + let bp = BitShown $ BS.concat (runListConduit blankedJsonToBalancedParens2 (getBlankedJson blankedJson)) + bp `shouldBe` fromString "11111111 11111111 00000000 11111111 00000000 00000000" + it "Blanking JSON should not contain strange characters 2" $ do + let blankedJson = BlankedJson ["[ [],", "[]]"] + let bp = BitShown $ BS.concat (runListConduit (blankedJsonToBalancedParens2 =$= compressWordAsBit) (getBlankedJson blankedJson)) + bp `shouldBe` fromString "11010000"