diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright John Ky (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,133 @@ +# hw-json +[![v0.0-branch](https://circleci.com/gh/haskell-works/hw-json/tree/v0.0-branch.svg?style=svg)](https://circleci.com/gh/haskell-works/hw-json/tree/v0.0-branch) + +Conduits for tokenizing streams. + +`hw-json` is a succinct JSON parsing library. It uses succinct data-structures to allow traversal of +large JSON strings with minimal memory overhead. + +It is currently considered experimental. + +For an example, see [`app/Main.hs`](../master/app/Main.hs) + +## Prerequisites +* Install `haskell-stack`. +* Install `hlint` (eg. `stack install hlint`) + +## Building + +Run the following in the shell: + + git clone git@github.com:haskell-works/hw-json.git + cd hw-json + stack setup + stack build + stack test + stack ghci --ghc-options -XOverloadedStrings \ + --main-is hw-json:exe:hw-json-example + +## Memory benchmark + +### Parsing large Json files in Scala with Argonaut + + S0U EU OU MU CCSU CMD + --------- --------- ----------- -------- -------- --------------------------------------------------------------- + 0.0 80,526.3 76,163.6 72,338.6 13,058.6 sbt console + 0.0 536,660.4 76,163.6 72,338.6 13,058.6 import java.io._, argonaut._, Argonaut._ + 0.0 552,389.1 76,163.6 72,338.6 13,058.6 val file = new File("/Users/jky/Downloads/78mbs.json" + 0.0 634,066.5 76,163.6 72,338.6 13,058.6 val array = new Array[Byte](file.length.asInstanceOf[Int]) + 0.0 644,552.3 76,163.6 72,338.6 13,058.6 val is = new FileInputStream("/Users/jky/Downloads/78mbs.json") + 0.0 655,038.1 76,163.6 72,338.6 13,058.6 is.read(array) + 294,976.0 160,159.7 1,100,365.0 79,310.8 13,748.1 val json = new String(array) + 285,182.9 146,392.6 1,956,264.5 82,679.8 14,099.6 val data = Parse.parse(json) + *********** + +### Parsing large Json files in Haskell with Aeson + + Mem (MB) CMD + -------- --------------------------------------------------------- + 302 import Data.Aeson + 302 import qualified Data.ByteString.Lazy as BSL + 302 json78m <- BSL.readFile "/Users/jky/Downloads/78mbs.json" + 1400 let !x = decode json78m :: Maybe Value + +### Parsing large Json files in Haskell with hw-json + + Mem (MB) CMD + -------- --------------------------------------------------------- + 274 import Foreign + 274 import qualified Data.Vector.Storable as DVS + 274 import qualified Data.ByteString as BS + 274 import System.IO.MMap + 274 import Data.Word + 274 (fptr :: ForeignPtr Word8, offset, size) <- mmapFileForeignPtr "/Users/jky/Downloads/78mbs.json" ReadOnly Nothing + 601 cursor <- measure (fromForeignRegion (fptr, offset, size) :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) + +## Examples + +### Performance example + + import Foreign + import qualified Data.Vector.Storable as DVS + import qualified Data.ByteString as BS + import qualified Data.ByteString.Internal as BSI + import System.IO.MMap + import Data.Word + import System.CPUTime + (fptr :: ForeignPtr Word8, offset, size) <- mmapFileForeignPtr "/Users/jky/Downloads/78mbs.json" ReadOnly Nothing + cursor <- measure (fromForeignRegion (fptr, offset, size) :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) + let !bs = BSI.fromForeignPtr (castForeignPtr fptr) offset size + x <- measure $ jsonBsToInterestBs bs + let !y = runListConduit [bs] (unescape' "") + + import Foreign + import qualified Data.Vector.Storable as DVS + import qualified Data.ByteString as BS + import qualified Data.ByteString.Internal as BSI + import System.IO.MMap + import Data.Word + import System.CPUTime + (fptr :: ForeignPtr Word8, offset, size) <- mmapFileForeignPtr "/Users/jky/Downloads/part40.json" ReadOnly Nothing + let !bs = BSI.fromForeignPtr (castForeignPtr fptr) offset size + x <- measure $ BS.concat $ runListConduit [bs] (blankJson =$= blankedJsonToInterestBits) + x <- measure $ jsonBsToInterestBs bs + + jsonTokenAt $ J.nextSibling $ J.firstChild $ J.nextSibling $ J.firstChild $ J.firstChild cursor + +### Navigation example + + $ cabal repl --ghc-option='-package mmap' + λ> :set -XNoMonomorphismRestriction + λ> import qualified Data.ByteString as BS + λ> import Data.String + λ> import qualified Data.Vector.Storable as DVS + λ> import Data.Word + λ> import HaskellWorks.Data.Bits.BitShow + λ> import HaskellWorks.Data.Bits.BitShown + λ> import HaskellWorks.Data.FromForeignRegion + λ> import HaskellWorks.Data.Json.Succinct.Cursor as C + λ> import HaskellWorks.Data.Json.Token + λ> import HaskellWorks.Data.Succinct.BalancedParens.Internal + λ> import HaskellWorks.Data.Succinct.BalancedParens.Simple + λ> 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.Succinct.RankSelect.Binary.Poppy512 + λ> import qualified HaskellWorks.Data.TreeCursor as TC + λ> import System.IO.MMap + λ> let fc = TC.firstChild + λ> let ns = TC.nextSibling + λ> let pn = TC.parent + λ> let cd = TC.depth + λ> let ss = TC.subtreeSize + λ> let cursor = "[null, {\"field\": 1}]" :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) + λ> cursor + +## References +* [Succinct Data Structures talk by Edward Kmett](https://www.youtube.com/watch?v=uA0Z7_4J7u8) +* [Typed Tagless Final Interpreters](http://okmij.org/ftp/tagless-final/course/lecture.pdf) +* [Conduit Overview](https://www.schoolofhaskell.com/school/to-infinity-and-beyond/pick-of-the-week/conduit-overview) + + +## Special mentions +* [Sydney Paper Club](http://www.meetup.com/Sydney-Paper-Club/) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import qualified Data.ByteString as BS +import qualified Data.Vector.Storable as DVS +import Data.Word +import GHC.Conc +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.FromByteString +import HaskellWorks.Data.Json.Succinct.Cursor +import HaskellWorks.Data.Succinct.BalancedParens.Simple +import HaskellWorks.Diagnostics.Time +import System.Mem + +readJson :: String -> IO (JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) +readJson path = do + bs <- BS.readFile path + print "Read file" + !cursor <- measure (fromByteString bs :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) + print "Created cursor" + return cursor + +main :: IO () +main = do + performGC + !c0 <- readJson "/Users/jky/Downloads/78mbs.json" + !c1 <- readJson "/Users/jky/Downloads/78mbs.json" + !c2 <- readJson "/Users/jky/Downloads/78mbs.json" + !c3 <- readJson "/Users/jky/Downloads/78mbs.json" + !c4 <- readJson "/Users/jky/Downloads/78mbs.json" + !c5 <- readJson "/Users/jky/Downloads/78mbs.json" + !c6 <- readJson "/Users/jky/Downloads/78mbs.json" + !c7 <- readJson "/Users/jky/Downloads/78mbs.json" + !c8 <- readJson "/Users/jky/Downloads/78mbs.json" + !c9 <- readJson "/Users/jky/Downloads/78mbs.json" + print "Returned from readJson" + performGC + threadDelay 100000000 + print c0 + print c1 + print c2 + print c3 + print c4 + print c5 + print c6 + print c7 + print c8 + print c9 diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Criterion.Main +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BSI +import qualified Data.Vector.Storable as DVS +import Data.Word +import Foreign +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.FromByteString +import HaskellWorks.Data.Json.Succinct.Cursor +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.Succinct.BalancedParens.Simple +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic +import System.IO.MMap + +setupEnvBs :: Int -> IO BS.ByteString +setupEnvBs n = return $ BS.pack (take n (cycle [maxBound, 0])) + +setupEnvBss :: Int -> Int -> IO [BS.ByteString] +setupEnvBss n k = setupEnvBs n >>= \v -> return (replicate k v) + +setupEnvVector :: Int -> IO (DVS.Vector Word64) +setupEnvVector n = return $ DVS.fromList (take n (cycle [maxBound, 0])) + +setupEnvVectors :: Int -> Int -> IO [DVS.Vector Word64] +setupEnvVectors n k = setupEnvVector n >>= \v -> return (replicate k v) + +setupEnvJson :: FilePath -> IO BS.ByteString +setupEnvJson filepath = do + (fptr :: ForeignPtr Word8, offset, size) <- mmapFileForeignPtr filepath ReadOnly Nothing + let !bs = BSI.fromForeignPtr (castForeignPtr fptr) offset size + return bs + +loadJson :: BS.ByteString -> JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) +loadJson bs = fromByteString bs :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) + +benchRankSelect :: [Benchmark] +benchRankSelect = + [ env (setupEnvVector 1000000) $ \bv -> bgroup "Rank" + [ bench "Rank - Once" (whnf (rank1 bv) 1) + , bench "Select - Once" (whnf (select1 bv) 1) + , bench "Rank - Many" (nf (map (getCount . rank1 bv)) [0, 1000..10000000]) + ] + ] + +benchRankJson40Conduits :: [Benchmark] +benchRankJson40Conduits = + [ env (setupEnvJson "/Users/jky/Downloads/part40.json") $ \bs -> bgroup "Json40" + [ bench "loadJson " (whnf loadJson bs) + ] + ] + +benchRankJson80Conduits :: [Benchmark] +benchRankJson80Conduits = + [ env (setupEnvJson "/Users/jky/Downloads/part80.json") $ \bs -> bgroup "Json40" + [ bench "loadJson" (whnf loadJson bs) + ] + ] + +benchRankJsonBigConduits :: [Benchmark] +benchRankJsonBigConduits = + [ env (setupEnvJson "/Users/jky/Downloads/78mb.json") $ \bs -> bgroup "JsonBig" + [ bench "loadJson" (whnf loadJson bs) + ] + ] + +benchBlankedJsonToBalancedParens :: [Benchmark] +benchBlankedJsonToBalancedParens = + [ env (setupEnvJson "/Users/jky/Downloads/part40.json") $ \bs -> bgroup "JsonBig" + [ bench "loadJson" (whnf loadJson bs) + ] + ] + +main :: IO () +main = defaultMain benchRankJson40Conduits diff --git a/hw-json.cabal b/hw-json.cabal new file mode 100644 --- /dev/null +++ b/hw-json.cabal @@ -0,0 +1,118 @@ +name: hw-json +version: 0.0.0.1 +synopsis: Conduits for tokenizing streams. +description: Please see README.md +homepage: http://github.com/haskell-works/hw-json#readme +license: BSD3 +license-file: LICENSE +author: John Ky +maintainer: newhoggy@gmail.com +copyright: 2016 John Ky +category: Data, Conduit +build-type: Simple +extra-source-files: README.md +cabal-version: >= 1.10 +data-files: test/data/sample.json + +executable hw-json-example + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 -Wall -msse4.2 + build-depends: base >= 4 + , bytestring + , conduit + , criterion + , hw-bits + , hw-conduit + , hw-diagnostics + , hw-json + , hw-prim + , hw-rankselect + , mmap + , resourcet + , vector + default-language: Haskell2010 + +library + hs-source-dirs: src + exposed-modules: HaskellWorks.Data.Json + , HaskellWorks.Data.Json.Extract + , HaskellWorks.Data.Json.Succinct + , HaskellWorks.Data.Json.Succinct.Cursor + , HaskellWorks.Data.Json.Succinct.Cursor.BalancedParens + , HaskellWorks.Data.Json.Succinct.Cursor.BlankedJson + , HaskellWorks.Data.Json.Succinct.Cursor.CursorType + , HaskellWorks.Data.Json.Succinct.Cursor.FromJsonCursor + , HaskellWorks.Data.Json.Succinct.Cursor.InterestBits + , HaskellWorks.Data.Json.Succinct.Cursor.Internal + , HaskellWorks.Data.Json.Succinct.Cursor.Token + , HaskellWorks.Data.Json.Token.Tokenize + , HaskellWorks.Data.Json.Token.Types + , HaskellWorks.Data.Json.Token + , HaskellWorks.Data.Json.Type + , HaskellWorks.Data.Json.Value + build-depends: base >= 4.7 && < 5 + , attoparsec + , bytestring + , conduit + , containers + , hw-bits + , hw-conduit + , hw-parser + , hw-prim + , hw-rankselect + , mono-traversable + , text + , vector + , word8 + + default-language: Haskell2010 + ghc-options: -rtsopts -with-rtsopts=-N -Wall -O2 -Wall -msse4.2 + +test-suite hw-json-test + 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 + , HaskellWorks.Data.Json.Succinct.Cursor.InterestBitsSpec + build-depends: base + , attoparsec + , bytestring + , conduit + , hspec + , hw-bits + , hw-conduit + , hw-json + , hw-prim + , hw-rankselect + , mmap + , parsec + , QuickCheck + , resourcet + , transformers + , vector + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/haskell-works/hw-json + +benchmark bench + Type: exitcode-stdio-1.0 + HS-Source-Dirs: bench + Main-Is: Main.hs + GHC-Options: -O2 -Wall -msse4.2 + Default-Language: Haskell2010 + Build-Depends: base >= 4 && < 5 + , bytestring + , conduit + , criterion + , hw-bits + , hw-json + , hw-prim + , hw-rankselect + , mmap + , resourcet + , vector diff --git a/src/HaskellWorks/Data/Json.hs b/src/HaskellWorks/Data/Json.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json.hs @@ -0,0 +1,11 @@ +-- | +-- Copyright: 2016 John Ky +-- License: MIT +-- +-- Json +module HaskellWorks.Data.Json + ( module X + ) where + +import HaskellWorks.Data.Json.Succinct as X +import HaskellWorks.Data.Json.Token as X diff --git a/src/HaskellWorks/Data/Json/Extract.hs b/src/HaskellWorks/Data/Json/Extract.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Extract.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE BangPatterns #-} + +module HaskellWorks.Data.Json.Extract + ( extractJsonSnippet + ) where + +import qualified Data.ByteString as BS +import Data.Word8 +import HaskellWorks.Data.Conduit.Json.Words +import HaskellWorks.Data.Json.Type + +data ExtractJsonState + = ExtractJsonStringEscaped + | ExtractJsonStringInJson + | ExtractJsonStringInNumber + | ExtractJsonStringInString + +extractJsonSnippet :: BS.ByteString -> Maybe (JsonType, BS.ByteString) +extractJsonSnippet bs = case extractJsonSnippet' 0 ExtractJsonStringInJson bs of + Just (jsonType, len) -> Just (jsonType, BS.take len bs) + Nothing -> Nothing + +extractJsonSnippet' :: Int -> ExtractJsonState -> BS.ByteString -> Maybe (JsonType, Int) +extractJsonSnippet' n ExtractJsonStringInJson bs = case BS.uncons bs of + Just (!c, !cs) | isLeadingDigit c -> extractJsonSnippet' (n + 1) ExtractJsonStringInNumber cs + Just (!c, !cs) | c == _quotedbl -> extractJsonSnippet' (n + 1) ExtractJsonStringInString cs + Just (!c, _) | c == _t -> Just (JsonTypeBool, n + 1) + Just (!c, _) | c == _f -> Just (JsonTypeBool, n + 1) + Just (!c, _) | c == _n -> Just (JsonTypeNull, n + 1) + Just (!c, _) | c == _braceleft -> Just (JsonTypeObject, n + 1) + Just (!c, _) | c == _bracketleft -> Just (JsonTypeArray, n + 1) + Just _ -> Nothing + Nothing -> Nothing +extractJsonSnippet' n ExtractJsonStringInString bs = case BS.uncons bs of + Just (!c, !cs) | c == _backslash -> extractJsonSnippet' (n + 1) ExtractJsonStringEscaped cs + Just (!c, _) | c == _quotedbl -> Just (JsonTypeString, n + 1) + Just (_ , !cs) -> extractJsonSnippet' (n + 1) ExtractJsonStringInString cs + Nothing -> Nothing +extractJsonSnippet' n ExtractJsonStringEscaped bs = case BS.uncons bs of + Just (_, !cs) -> extractJsonSnippet' (n + 1) ExtractJsonStringInString cs + Nothing -> Nothing +extractJsonSnippet' n ExtractJsonStringInNumber bs = case BS.uncons bs of + Just (!c, !cs) | isTrailingDigit c -> extractJsonSnippet' (n + 1) ExtractJsonStringInNumber cs + Just _ -> Just (JsonTypeNumber, n) + Nothing -> Just (JsonTypeNumber, n) diff --git a/src/HaskellWorks/Data/Json/Succinct.hs b/src/HaskellWorks/Data/Json/Succinct.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Succinct.hs @@ -0,0 +1,5 @@ +module HaskellWorks.Data.Json.Succinct + ( module X + ) where + +import HaskellWorks.Data.Json.Succinct.Cursor as X diff --git a/src/HaskellWorks/Data/Json/Succinct/Cursor.hs b/src/HaskellWorks/Data/Json/Succinct/Cursor.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Succinct/Cursor.hs @@ -0,0 +1,8 @@ + +module HaskellWorks.Data.Json.Succinct.Cursor + ( module X + ) where + +import HaskellWorks.Data.Json.Succinct.Cursor.CursorType as X +import HaskellWorks.Data.Json.Succinct.Cursor.Internal as X +import HaskellWorks.Data.Json.Succinct.Cursor.Token as X diff --git a/src/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParens.hs b/src/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParens.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Succinct/Cursor/BalancedParens.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module HaskellWorks.Data.Json.Succinct.Cursor.BalancedParens + ( JsonBalancedParens(..) + , getJsonBalancedParens + ) where + +import Control.Applicative +import qualified Data.ByteString as BS +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.Succinct.Cursor.BlankedJson +import HaskellWorks.Data.Succinct.BalancedParens as BP + +newtype JsonBalancedParens a = JsonBalancedParens a + +getJsonBalancedParens :: JsonBalancedParens a -> a +getJsonBalancedParens (JsonBalancedParens a) = a + +genBitWordsForever :: BS.ByteString -> Maybe (Word8, BS.ByteString) +genBitWordsForever bs = BS.uncons bs <|> Just (0, bs) +{-# INLINABLE genBitWordsForever #-} + +instance FromBlankedJson (JsonBalancedParens (SimpleBalancedParens [Bool])) where + 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 + +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 + +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 + +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 diff --git a/src/HaskellWorks/Data/Json/Succinct/Cursor/BlankedJson.hs b/src/HaskellWorks/Data/Json/Succinct/Cursor/BlankedJson.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Succinct/Cursor/BlankedJson.hs @@ -0,0 +1,23 @@ + +module HaskellWorks.Data.Json.Succinct.Cursor.BlankedJson + ( BlankedJson(..) + , FromBlankedJson(..) + , getBlankedJson + ) where + +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 + +newtype BlankedJson = BlankedJson [BS.ByteString] deriving (Eq, Show) + +getBlankedJson :: BlankedJson -> [BS.ByteString] +getBlankedJson (BlankedJson bs) = bs + +class FromBlankedJson a where + fromBlankedJson :: BlankedJson -> a + +instance FromByteString BlankedJson where + fromByteString bs = BlankedJson (runListConduit blankJson (chunkedBy 4064 bs)) diff --git a/src/HaskellWorks/Data/Json/Succinct/Cursor/CursorType.hs b/src/HaskellWorks/Data/Json/Succinct/Cursor/CursorType.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Succinct/Cursor/CursorType.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module HaskellWorks.Data.Json.Succinct.Cursor.CursorType + ( HasJsonCursorType(..) + , JsonCursorType(..) + , jsonCursorPos + ) where + +import qualified Data.ByteString as BS +import Data.Char +import HaskellWorks.Data.Json.Succinct.Cursor.Internal +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank1 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select1 +import HaskellWorks.Data.Vector.VectorLike + +data JsonCursorType + = JsonCursorArray + | JsonCursorBool + | JsonCursorNull + | JsonCursorNumber + | JsonCursorObject + | JsonCursorString + deriving (Eq, Show) + +class HasJsonCursorType k where + jsonCursorType :: k -> JsonCursorType + +jsonCursorType' :: Char -> JsonCursorType +jsonCursorType' c = case c of + '[' -> JsonCursorArray + 't' -> JsonCursorBool + 'f' -> JsonCursorBool + '0' -> JsonCursorNumber + '1' -> JsonCursorNumber + '2' -> JsonCursorNumber + '3' -> JsonCursorNumber + '4' -> JsonCursorNumber + '5' -> JsonCursorNumber + '6' -> JsonCursorNumber + '7' -> JsonCursorNumber + '8' -> JsonCursorNumber + '9' -> JsonCursorNumber + '+' -> JsonCursorNumber + '-' -> JsonCursorNumber + 'n' -> JsonCursorNull + '{' -> JsonCursorObject + '"' -> JsonCursorString + _ -> error "Invalid JsonCursor cursorRank" + +jsonCursorPos :: (Rank1 w, Select1 v, VectorLike s) => JsonCursor s v w -> Position +jsonCursorPos k = toPosition (select1 ik (rank1 bpk (cursorRank k)) - 1) + where ik = interests k + bpk = balancedParens k + +jsonCursorElemAt :: (Rank1 w, Select1 v, VectorLike s) => JsonCursor s v w -> Elem s +jsonCursorElemAt k = cursorText k !!! jsonCursorPos k + +instance (Rank1 i, Select1 i, Rank1 b) => HasJsonCursorType (JsonCursor String i b) where + jsonCursorType = jsonCursorType' . jsonCursorElemAt + +instance (Rank1 i, Select1 i, Rank1 b) => HasJsonCursorType (JsonCursor BS.ByteString i b) where + jsonCursorType = jsonCursorType' . chr . fromIntegral . jsonCursorElemAt diff --git a/src/HaskellWorks/Data/Json/Succinct/Cursor/FromJsonCursor.hs b/src/HaskellWorks/Data/Json/Succinct/Cursor/FromJsonCursor.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Succinct/Cursor/FromJsonCursor.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module HaskellWorks.Data.Json.Succinct.Cursor.FromJsonCursor where + +import qualified Data.ByteString as BS +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Json.Succinct.Cursor.Internal +import HaskellWorks.Data.Json.Succinct.Cursor.Token +import HaskellWorks.Data.Json.Value +import HaskellWorks.Data.Json.Token.Types +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank1 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select1 +import HaskellWorks.Data.TreeCursor + +class FromJsonCursor t v w a where + fromJsonCursor :: JsonCursor t v w -> a + +instance (TreeCursor (JsonCursor BS.ByteString v w), Rank1 w, Select1 v, TestBit w) => FromJsonCursor BS.ByteString v w (JsonValue BS.ByteString BS.ByteString) where + fromJsonCursor k = case jsonTokenAt k of + Just JsonTokenBraceL -> undefined + Just JsonTokenBraceR -> undefined + Just JsonTokenBracketL -> undefined + Just JsonTokenBracketR -> undefined + Just JsonTokenComma -> undefined + Just JsonTokenColon -> undefined + Just JsonTokenWhitespace -> undefined + Just (JsonTokenString _) -> undefined + Just (JsonTokenBoolean value) -> JsonBool value + Just (JsonTokenNumber _) -> undefined + Just JsonTokenNull -> undefined + Nothing -> undefined diff --git a/src/HaskellWorks/Data/Json/Succinct/Cursor/InterestBits.hs b/src/HaskellWorks/Data/Json/Succinct/Cursor/InterestBits.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Succinct/Cursor/InterestBits.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module HaskellWorks.Data.Json.Succinct.Cursor.InterestBits + ( JsonInterestBits(..) + , getJsonInterestBits + ) where + +import Control.Applicative +import qualified Data.ByteString as BS +import Data.ByteString.Internal +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.Succinct.Cursor.BlankedJson +import HaskellWorks.Data.Succinct.RankSelect.Binary.Poppy512 + +newtype JsonInterestBits a = JsonInterestBits a + +getJsonInterestBits :: JsonInterestBits a -> a +getJsonInterestBits (JsonInterestBits a) = a + +blankedJsonBssToInterestBitsBs :: [ByteString] -> ByteString +blankedJsonBssToInterestBitsBs bss = BS.concat $ runListConduit blankedJsonToInterestBits bss + +genInterest :: ByteString -> Maybe (Word8, ByteString) +genInterest = BS.uncons + +genInterestForever :: ByteString -> Maybe (Word8, ByteString) +genInterestForever bs = BS.uncons bs <|> Just (0, bs) + +instance FromBlankedJson (JsonInterestBits (BitShown [Bool])) where + fromBlankedJson = JsonInterestBits . fromByteString . BS.concat . runListConduit blankedJsonToInterestBits . getBlankedJson + +instance FromBlankedJson (JsonInterestBits (BitShown BS.ByteString)) where + fromBlankedJson = JsonInterestBits . BitShown . BS.unfoldr genInterest . blankedJsonBssToInterestBitsBs . getBlankedJson + +instance FromBlankedJson (JsonInterestBits (BitShown (DVS.Vector Word8))) where + fromBlankedJson = JsonInterestBits . BitShown . DVS.unfoldr genInterest . blankedJsonBssToInterestBitsBs . getBlankedJson + +instance FromBlankedJson (JsonInterestBits (BitShown (DVS.Vector Word16))) where + fromBlankedJson bj = JsonInterestBits (BitShown (DVS.unsafeCast (DVS.unfoldrN newLen genInterestForever interestBS))) + where interestBS = blankedJsonBssToInterestBitsBs (getBlankedJson bj) + newLen = (BS.length interestBS + 1) `div` 2 * 2 + +instance FromBlankedJson (JsonInterestBits (BitShown (DVS.Vector Word32))) where + fromBlankedJson bj = JsonInterestBits (BitShown (DVS.unsafeCast (DVS.unfoldrN newLen genInterestForever interestBS))) + where interestBS = blankedJsonBssToInterestBitsBs (getBlankedJson bj) + newLen = (BS.length interestBS + 3) `div` 4 * 4 + +instance FromBlankedJson (JsonInterestBits (BitShown (DVS.Vector Word64))) where + fromBlankedJson bj = JsonInterestBits (BitShown (DVS.unsafeCast (DVS.unfoldrN newLen genInterestForever interestBS))) + where interestBS = blankedJsonBssToInterestBitsBs (getBlankedJson bj) + newLen = (BS.length interestBS + 7) `div` 8 * 8 + +instance FromBlankedJson (JsonInterestBits Poppy512) where + fromBlankedJson = JsonInterestBits . makePoppy512 . bitShown . getJsonInterestBits . fromBlankedJson diff --git a/src/HaskellWorks/Data/Json/Succinct/Cursor/Internal.hs b/src/HaskellWorks/Data/Json/Succinct/Cursor/Internal.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Succinct/Cursor/Internal.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module HaskellWorks.Data.Json.Succinct.Cursor.Internal + ( JsonCursor(..) + ) where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.ByteString.Internal as BSI +import Data.String +import qualified Data.Vector.Storable as DVS +import Data.Word +import Data.Word8 +import Foreign.ForeignPtr +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.FromByteString +import HaskellWorks.Data.FromForeignRegion +import HaskellWorks.Data.Json.Succinct.Cursor.BalancedParens +import HaskellWorks.Data.Json.Succinct.Cursor.BlankedJson +import HaskellWorks.Data.Json.Succinct.Cursor.InterestBits +import HaskellWorks.Data.Json.Type +import HaskellWorks.Data.Json.Value +import HaskellWorks.Data.Positioning +import 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.Poppy512 +import HaskellWorks.Data.TreeCursor +import HaskellWorks.Data.Vector.VectorLike + +data JsonCursor t v w = JsonCursor + { cursorText :: !t + , interests :: !v + , balancedParens :: !w + , cursorRank :: !Count + } + deriving (Eq, Show) + +instance (FromBlankedJson (JsonInterestBits a), FromBlankedJson (JsonBalancedParens b)) + => FromByteString (JsonCursor BS.ByteString a b) where + fromByteString bs = JsonCursor + { cursorText = bs + , interests = getJsonInterestBits (fromBlankedJson blankedJson) + , balancedParens = getJsonBalancedParens (fromBlankedJson blankedJson) + , cursorRank = 1 + } + where blankedJson :: BlankedJson + blankedJson = fromByteString bs + +instance IsString (JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool])) where + fromString :: String -> JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + fromString s = JsonCursor + { cursorText = s + , cursorRank = 1 + , interests = getJsonInterestBits (fromBlankedJson blankedJson) + , balancedParens = getJsonBalancedParens (fromBlankedJson blankedJson) + } + where blankedJson :: BlankedJson + blankedJson = fromByteString (BSC.pack s) + +instance IsString (JsonCursor BS.ByteString (BitShown (DVS.Vector Word8)) (SimpleBalancedParens (DVS.Vector Word8))) where + fromString = fromByteString . BSC.pack + +instance IsString (JsonCursor BS.ByteString (BitShown (DVS.Vector Word16)) (SimpleBalancedParens (DVS.Vector Word16))) where + fromString = fromByteString . BSC.pack + +instance IsString (JsonCursor BS.ByteString (BitShown (DVS.Vector Word32)) (SimpleBalancedParens (DVS.Vector Word32))) where + fromString = fromByteString . BSC.pack + +instance IsString (JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) where + fromString = fromByteString . BSC.pack + +instance IsString (JsonCursor BS.ByteString Poppy512 (SimpleBalancedParens (DVS.Vector Word64))) where + fromString = fromByteString . BSC.pack + +instance FromForeignRegion (JsonCursor BS.ByteString (BitShown (DVS.Vector Word8)) (SimpleBalancedParens (DVS.Vector Word8))) where + fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (castForeignPtr fptr) offset size) + +instance FromForeignRegion (JsonCursor BS.ByteString (BitShown (DVS.Vector Word16)) (SimpleBalancedParens (DVS.Vector Word16))) where + fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (castForeignPtr fptr) offset size) + +instance FromForeignRegion (JsonCursor BS.ByteString (BitShown (DVS.Vector Word32)) (SimpleBalancedParens (DVS.Vector Word32))) where + fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (castForeignPtr fptr) offset size) + +instance FromForeignRegion (JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) where + fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (castForeignPtr fptr) offset size) + +instance FromForeignRegion (JsonCursor BS.ByteString Poppy512 (SimpleBalancedParens (DVS.Vector Word64))) where + fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (castForeignPtr fptr) offset size) + +instance (BP.BalancedParens u, Rank1 u, Rank0 u) => TreeCursor (JsonCursor t v u) where + firstChild :: JsonCursor t v u -> JsonCursor t v u + firstChild k = k { cursorRank = BP.firstChild (balancedParens k) (cursorRank k) } + + nextSibling :: JsonCursor t v u -> JsonCursor t v u + nextSibling k = k { cursorRank = BP.nextSibling (balancedParens k) (cursorRank k) } + + parent :: JsonCursor t v u -> JsonCursor t v u + parent k = k { cursorRank = BP.parent (balancedParens k) (cursorRank k) } + + depth :: JsonCursor t v u -> Count + depth k = BP.depth (balancedParens k) (cursorRank k) + + subtreeSize :: JsonCursor t v u -> Count + subtreeSize k = BP.subtreeSize (balancedParens k) (cursorRank k) + +wIsJsonNumberDigit :: Word8 -> Bool +wIsJsonNumberDigit w = (w >= _0 && w <= _9) || w == _hyphen + +instance TestBit w => JsonTypeAt (JsonCursor BS.ByteString v w) where + jsonTypeAtPosition p k = if balancedParens k .?. p + then case cursorText k !!! p of + c | c == _bracketleft -> Just JsonTypeArray + c | c == _t -> Just JsonTypeBool + c | c == _n -> Just JsonTypeNull + c | wIsJsonNumberDigit c -> Just JsonTypeNumber + c | c == _braceleft -> Just JsonTypeObject + c | c == _quotedbl -> Just JsonTypeString + _ -> Nothing + else Nothing + + jsonTypeAt k = jsonTypeAtPosition (lastPositionOf (cursorRank k)) k + +instance TestBit w => JsonValueAt BS.ByteString BS.ByteString (JsonCursor BS.ByteString v w) where + jsonValueAt :: JsonCursor BS.ByteString v w -> Maybe (JsonValue BS.ByteString BS.ByteString) + jsonValueAt k = case jsonTypeAtPosition p k of + Just JsonTypeArray -> error "Not Implemented" + Just JsonTypeBool -> case cursorText k !!! p of + c | c == _t -> Just $ JsonBool True + c | c == _t -> Just $ JsonBool False + _ -> Nothing + Just JsonTypeNull -> Just JsonNull + Just JsonTypeNumber -> error "Not Implemented" + Just JsonTypeObject -> error "Not Implemented" + Just JsonTypeString -> error "Not Implemented" + Nothing -> Nothing + where p = lastPositionOf (cursorRank k) diff --git a/src/HaskellWorks/Data/Json/Succinct/Cursor/Token.hs b/src/HaskellWorks/Data/Json/Succinct/Cursor/Token.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Succinct/Cursor/Token.hs @@ -0,0 +1,23 @@ + +module HaskellWorks.Data.Json.Succinct.Cursor.Token + ( jsonTokenAt + ) where + +import qualified Data.Attoparsec.ByteString.Char8 as ABC +import Data.ByteString.Internal as BSI +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Json.Succinct.Cursor.CursorType +import HaskellWorks.Data.Json.Succinct.Cursor.Internal +import HaskellWorks.Data.Json.Token.Tokenize +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Rank1 +import HaskellWorks.Data.Succinct.RankSelect.Binary.Basic.Select1 +import HaskellWorks.Data.Vector.VectorLike + +jsonTokenAt :: (Rank1 w, Select1 v, TestBit w) => JsonCursor ByteString v w -> Maybe (JsonToken String Double) +jsonTokenAt k = if balancedParens k .?. lastPositionOf (cursorRank k) + then case ABC.parse parseJsonToken (vDrop (toCount (jsonCursorPos k)) (cursorText k)) of + ABC.Fail {} -> error "Failed to parse token in cursor" + ABC.Partial _ -> error "Failed to parse token in cursor" + ABC.Done _ r -> Just r + else Nothing diff --git a/src/HaskellWorks/Data/Json/Token.hs b/src/HaskellWorks/Data/Json/Token.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Token.hs @@ -0,0 +1,6 @@ +module HaskellWorks.Data.Json.Token + ( module X + ) where + +import HaskellWorks.Data.Json.Token.Types as X +import HaskellWorks.Data.Json.Token.Tokenize as X diff --git a/src/HaskellWorks/Data/Json/Token/Tokenize.hs b/src/HaskellWorks/Data/Json/Token/Tokenize.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Token/Tokenize.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module HaskellWorks.Data.Json.Token.Tokenize + ( IsChar(..) + , JsonToken(..) + , ParseJson(..) + ) where + +import Control.Applicative +import qualified Data.Attoparsec.ByteString.Char8 as BC +import qualified Data.Attoparsec.Combinator as AC +import qualified Data.Attoparsec.Types as T +import qualified Data.ByteString as BS +import Data.Bits +import Data.Char +import Data.Word +import Data.Word8 +import HaskellWorks.Data.Char.IsChar +import HaskellWorks.Data.Json.Token.Types +import HaskellWorks.Data.Parser as P + +hexDigitNumeric :: P.Parser t => T.Parser t Int +hexDigitNumeric = do + c <- satisfyChar (\c -> '0' <= c && c <= '9') + return $ ord c - ord '0' + +hexDigitAlphaLower :: P.Parser t => T.Parser t Int +hexDigitAlphaLower = do + c <- satisfyChar (\c -> 'a' <= c && c <= 'z') + return $ ord c - ord 'a' + 10 + +hexDigitAlphaUpper :: P.Parser t => T.Parser t Int +hexDigitAlphaUpper = do + c <- satisfyChar (\c -> 'A' <= c && c <= 'Z') + return $ ord c - ord 'A' + 10 + +hexDigit :: P.Parser t => T.Parser t Int +hexDigit = hexDigitNumeric <|> hexDigitAlphaLower <|> hexDigitAlphaUpper + +class ParseJson t s d where + parseJsonTokenString :: T.Parser t (JsonToken s d) + parseJsonToken :: T.Parser t (JsonToken s d) + parseJsonTokenBraceL :: T.Parser t (JsonToken s d) + parseJsonTokenBraceR :: T.Parser t (JsonToken s d) + parseJsonTokenBracketL :: T.Parser t (JsonToken s d) + parseJsonTokenBracketR :: T.Parser t (JsonToken s d) + parseJsonTokenComma :: T.Parser t (JsonToken s d) + parseJsonTokenColon :: T.Parser t (JsonToken s d) + parseJsonTokenWhitespace :: T.Parser t (JsonToken s d) + parseJsonTokenNull :: T.Parser t (JsonToken s d) + parseJsonTokenBoolean :: T.Parser t (JsonToken s d) + parseJsonTokenDouble :: T.Parser t (JsonToken s d) + + parseJsonToken = + parseJsonTokenString <|> + parseJsonTokenBraceL <|> + parseJsonTokenBraceR <|> + parseJsonTokenBracketL <|> + parseJsonTokenBracketR <|> + parseJsonTokenComma <|> + parseJsonTokenColon <|> + parseJsonTokenWhitespace <|> + parseJsonTokenNull <|> + parseJsonTokenBoolean <|> + parseJsonTokenDouble + +instance ParseJson BS.ByteString String Double where + parseJsonTokenBraceL = string "{" >> return JsonTokenBraceL + parseJsonTokenBraceR = string "}" >> return JsonTokenBraceR + parseJsonTokenBracketL = string "[" >> return JsonTokenBracketL + parseJsonTokenBracketR = string "]" >> return JsonTokenBracketR + parseJsonTokenComma = string "," >> return JsonTokenComma + parseJsonTokenColon = string ":" >> return JsonTokenColon + parseJsonTokenNull = string "null" >> return JsonTokenNull + parseJsonTokenDouble = JsonTokenNumber <$> rational + + parseJsonTokenString = do + _ <- string "\"" + value <- many (verbatimChar <|> escapedChar <|> escapedCode) + _ <- string "\"" + return $ JsonTokenString value + where + verbatimChar = satisfyChar (BC.notInClass "\"\\") "invalid string character" + escapedChar = do + _ <- string "\\" + ( char '"' >> return '"' ) <|> + ( char 'b' >> return '\b' ) <|> + ( char 'n' >> return '\n' ) <|> + ( char 'f' >> return '\f' ) <|> + ( char 'r' >> return '\r' ) <|> + ( char 't' >> return '\t' ) <|> + ( char '\\' >> return '\\' ) <|> + ( char '\'' >> return '\'' ) <|> + ( char '/' >> return '/' ) + escapedCode = do + _ <- string "\\u" + a <- hexDigit + b <- hexDigit + c <- hexDigit + d <- hexDigit + return $ chr $ a `shift` 24 .|. b `shift` 16 .|. c `shift` 8 .|. d + + parseJsonTokenWhitespace = do + _ <- AC.many1' $ BC.choice [string " ", string "\t", string "\n", string "\r"] + return JsonTokenWhitespace + + parseJsonTokenBoolean = true <|> false + where + true = string "true" >> return (JsonTokenBoolean True) + false = string "false" >> return (JsonTokenBoolean False) + +instance ParseJson BS.ByteString BS.ByteString Double where + parseJsonTokenBraceL = string "{" >> return JsonTokenBraceL + parseJsonTokenBraceR = string "}" >> return JsonTokenBraceR + parseJsonTokenBracketL = string "[" >> return JsonTokenBracketL + parseJsonTokenBracketR = string "]" >> return JsonTokenBracketR + parseJsonTokenComma = string "," >> return JsonTokenComma + parseJsonTokenColon = string ":" >> return JsonTokenColon + parseJsonTokenNull = string "null" >> return JsonTokenNull + parseJsonTokenDouble = JsonTokenNumber <$> rational + + parseJsonTokenString = do + _ <- string "\"" + value <- many (verbatimChar <|> escapedChar <|> escapedCode) + _ <- string "\"" + return $ JsonTokenString $ BS.pack value + where + word :: Word8 -> T.Parser BS.ByteString Word8 + word w = satisfy (== w) + verbatimChar :: T.Parser BS.ByteString Word8 + verbatimChar = satisfy (\w -> w /= _quotedbl && w /= _backslash) -- "invalid string character" + escapedChar :: T.Parser BS.ByteString Word8 + escapedChar = do + _ <- string "\\" + ( word _quotedbl >> return _quotedbl ) <|> + ( word _b >> return 0x08 ) <|> + ( word _n >> return _lf ) <|> + ( word _f >> return _np ) <|> + ( word _r >> return _cr ) <|> + ( word _t >> return _tab ) <|> + ( word _backslash >> return _backslash ) <|> + ( word _quotesingle >> return _quotesingle ) <|> + ( word _slash >> return _slash ) + escapedCode :: T.Parser BS.ByteString Word8 + escapedCode = do + _ <- string "\\u" + a <- hexDigit + b <- hexDigit + c <- hexDigit + d <- hexDigit + return $ fromIntegral $ a `shift` 24 .|. b `shift` 16 .|. c `shift` 8 .|. d + + parseJsonTokenWhitespace = do + _ <- AC.many1' $ BC.choice [string " ", string "\t", string "\n", string "\r"] + return JsonTokenWhitespace + + parseJsonTokenBoolean = true <|> false + where + true = string "true" >> return (JsonTokenBoolean True) + false = string "false" >> return (JsonTokenBoolean False) diff --git a/src/HaskellWorks/Data/Json/Token/Types.hs b/src/HaskellWorks/Data/Json/Token/Types.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Token/Types.hs @@ -0,0 +1,15 @@ +module HaskellWorks.Data.Json.Token.Types (JsonToken(..)) where + +data JsonToken s d + = JsonTokenBraceL + | JsonTokenBraceR + | JsonTokenBracketL + | JsonTokenBracketR + | JsonTokenComma + | JsonTokenColon + | JsonTokenWhitespace + | JsonTokenString s + | JsonTokenBoolean Bool + | JsonTokenNumber d + | JsonTokenNull + deriving (Eq, Show) diff --git a/src/HaskellWorks/Data/Json/Type.hs b/src/HaskellWorks/Data/Json/Type.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Type.hs @@ -0,0 +1,16 @@ +module HaskellWorks.Data.Json.Type where + +import HaskellWorks.Data.Positioning + +data JsonType + = JsonTypeArray + | JsonTypeBool + | JsonTypeNull + | JsonTypeNumber + | JsonTypeObject + | JsonTypeString + deriving (Eq, Show) + +class JsonTypeAt a where + jsonTypeAtPosition :: Position -> a -> Maybe JsonType + jsonTypeAt :: a -> Maybe JsonType diff --git a/src/HaskellWorks/Data/Json/Value.hs b/src/HaskellWorks/Data/Json/Value.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Json/Value.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module HaskellWorks.Data.Json.Value where + +import Data.Map + +data JsonValue s n + = JsonString s + | JsonNumber n + | JsonObject (Map s (JsonValue s n)) + | JsonArray [JsonValue s n] + | JsonBool Bool + | JsonNull + deriving (Eq, Show) + +class JsonValueAt s n a where + jsonValueAt :: a -> Maybe (JsonValue s n) diff --git a/test/HaskellWorks/Data/Json/Succinct/Cursor/InterestBitsSpec.hs b/test/HaskellWorks/Data/Json/Succinct/Cursor/InterestBitsSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Json/Succinct/Cursor/InterestBitsSpec.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + + +module HaskellWorks.Data.Json.Succinct.Cursor.InterestBitsSpec(spec) where + +import qualified Data.ByteString as BS +import Data.String +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.FromByteString +import HaskellWorks.Data.Json.Succinct.Cursor.BlankedJson +import HaskellWorks.Data.Json.Succinct.Cursor.InterestBits +import Test.Hspec + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} + +interestBitsOf :: FromBlankedJson (JsonInterestBits a) => BS.ByteString -> a +interestBitsOf = getJsonInterestBits . fromBlankedJson . fromByteString + +spec :: Spec +spec = describe "HaskellWorks.Data.Json.Succinct.Cursor.InterestBitsSpec" $ do + it "Evaluating interest bits" $ do + (interestBitsOf "" :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "" + (interestBitsOf " \n \r \t " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "00000000" + (interestBitsOf "1234 " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10000000" + (interestBitsOf "false " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10000000" + (interestBitsOf "true " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10000000" + (interestBitsOf "\"hello\" " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10000000" + (interestBitsOf "\"\\\"\" " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10000000" + (interestBitsOf "{ " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10000000" + (interestBitsOf "} " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "00000000" + (interestBitsOf "[ " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10000000" + (interestBitsOf "] " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "00000000" + (interestBitsOf ": " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "00000000" + (interestBitsOf ", " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "00000000" + (interestBitsOf "{{}}" :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "11000000" + (interestBitsOf " { { } } " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "01010000 00000000" diff --git a/test/HaskellWorks/Data/Json/Succinct/CursorSpec.hs b/test/HaskellWorks/Data/Json/Succinct/CursorSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Json/Succinct/CursorSpec.hs @@ -0,0 +1,251 @@ +{-# 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.Succinct.CursorSpec(spec) where + +import qualified Data.ByteString as BS +import Data.String +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.Bits.BitShow +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.FromForeignRegion +import HaskellWorks.Data.Json.Succinct.Cursor as C +import HaskellWorks.Data.Json.Token +import HaskellWorks.Data.Succinct.BalancedParens.Internal +import HaskellWorks.Data.Succinct.BalancedParens.Simple +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.Succinct.RankSelect.Binary.Poppy512 +import qualified HaskellWorks.Data.TreeCursor as TC +import System.IO.MMap +import Test.Hspec + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} +{-# ANN module ("HLint: redundant bracket" :: String) #-} + +fc = TC.firstChild +ns = TC.nextSibling +pn = TC.parent +cd = TC.depth +ss = TC.subtreeSize + +spec :: Spec +spec = describe "HaskellWorks.Data.Json.Succinct.CursorSpec" $ do + describe "Cursor for [Bool]" $ do + it "initialises to beginning of empty object" $ do + let cursor = "{}" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + jsonCursorType cursor `shouldBe` JsonCursorObject + it "initialises to beginning of empty object preceded by spaces" $ do + let cursor = " {}" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + jsonCursorType cursor `shouldBe` JsonCursorObject + it "initialises to beginning of number" $ do + let cursor = "1234" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + jsonCursorType cursor `shouldBe` JsonCursorNumber + it "initialises to beginning of string" $ do + let cursor = "\"Hello\"" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + jsonCursorType cursor `shouldBe` JsonCursorString + it "initialises to beginning of array" $ do + let cursor = "[]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + jsonCursorType cursor `shouldBe` JsonCursorArray + it "initialises to beginning of boolean true" $ do + let cursor = "true" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + jsonCursorType cursor `shouldBe` JsonCursorBool + it "initialises to beginning of boolean false" $ do + let cursor = "false" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + jsonCursorType cursor `shouldBe` JsonCursorBool + it "initialises to beginning of null" $ do + let cursor = "null" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + jsonCursorType cursor `shouldBe` JsonCursorNull + it "cursor can navigate to first child of array" $ do + let cursor = "[null]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + jsonCursorType (fc cursor) `shouldBe` JsonCursorNull + it "cursor can navigate to second child of array" $ do + let cursor = "[null, {\"field\": 1}]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + jsonCursorType ((ns . fc) cursor) `shouldBe` JsonCursorObject + it "cursor can navigate to first child of object at second child of array" $ do + let cursor = "[null, {\"field\": 1}]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + jsonCursorType ((fc . ns . fc) cursor) `shouldBe` JsonCursorString + it "cursor can navigate to first child of object at second child of array" $ do + let cursor = "[null, {\"field\": 1}]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + jsonCursorType ((ns . fc . ns . fc) cursor) `shouldBe` JsonCursorNumber + it "depth at top" $ do + let cursor = "[null]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + cd cursor `shouldBe` 1 + it "depth at first child of array" $ do + let cursor = "[null]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + cd (fc cursor) `shouldBe` 2 + it "depth at second child of array" $ do + let cursor = "[null, {\"field\": 1}]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + cd ((ns . fc) cursor) `shouldBe` 2 + it "depth at first child of object at second child of array" $ do + let cursor = "[null, {\"field\": 1}]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + cd ((fc . ns . fc) cursor) `shouldBe` 3 + it "depth at first child of object at second child of array" $ do + let cursor = "[null, {\"field\": 1}]" :: JsonCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + cd ((ns . fc . ns . fc) cursor) `shouldBe` 3 + genSpec "DVS.Vector Word8" (undefined :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word8)) (SimpleBalancedParens (DVS.Vector Word8))) + genSpec "DVS.Vector Word16" (undefined :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word16)) (SimpleBalancedParens (DVS.Vector Word16))) + genSpec "DVS.Vector Word32" (undefined :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word32)) (SimpleBalancedParens (DVS.Vector Word32))) + genSpec "DVS.Vector Word64" (undefined :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) + genSpec "Poppy512" (undefined :: JsonCursor BS.ByteString Poppy512 (SimpleBalancedParens (DVS.Vector Word64))) + it "Loads same Json consistentally from different backing vectors" $ do + let cursor8 = "{\n \"widget\": {\n \"debug\": \"on\" } }" :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word8)) (SimpleBalancedParens (DVS.Vector Word8)) + let cursor16 = "{\n \"widget\": {\n \"debug\": \"on\" } }" :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word16)) (SimpleBalancedParens (DVS.Vector Word16)) + let cursor32 = "{\n \"widget\": {\n \"debug\": \"on\" } }" :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word32)) (SimpleBalancedParens (DVS.Vector Word32)) + let cursor64 = "{\n \"widget\": {\n \"debug\": \"on\" } }" :: JsonCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) + cursorText cursor8 `shouldBe` cursorText cursor16 + cursorText cursor8 `shouldBe` cursorText cursor32 + cursorText cursor8 `shouldBe` cursorText cursor64 + let ic8 = bitShow $ interests cursor8 + let ic16 = bitShow $ interests cursor16 + let ic32 = bitShow $ interests cursor32 + let ic64 = bitShow $ interests cursor64 + ic16 `shouldBeginWith` ic8 + ic32 `shouldBeginWith` ic16 + ic64 `shouldBeginWith` ic32 + +shouldBeginWith :: (Eq a, Show a) => [a] -> [a] -> IO () +shouldBeginWith as bs = take (length bs) as `shouldBe` bs + +genSpec :: forall t u. + ( Eq t + , Show t + , Select1 t + , Eq u + , Show u + , Rank0 u + , Rank1 u + , BalancedParens u + , TestBit u + , FromForeignRegion (JsonCursor BS.ByteString t u) + , IsString (JsonCursor BS.ByteString t u) + , HasJsonCursorType (JsonCursor BS.ByteString t u)) + => String -> (JsonCursor BS.ByteString t u) -> SpecWith () +genSpec t _ = do + describe ("Cursor for (" ++ t ++ ")") $ do + it "initialises to beginning of empty object" $ do + let cursor = "{}" :: JsonCursor BS.ByteString t u + jsonCursorType cursor `shouldBe` JsonCursorObject + it "initialises to beginning of empty object preceded by spaces" $ do + let cursor = " {}" :: JsonCursor BS.ByteString t u + jsonCursorType cursor `shouldBe` JsonCursorObject + it "initialises to beginning of number" $ do + let cursor = "1234" :: JsonCursor BS.ByteString t u + jsonCursorType cursor `shouldBe` JsonCursorNumber + it "initialises to beginning of string" $ do + let cursor = "\"Hello\"" :: JsonCursor BS.ByteString t u + jsonCursorType cursor `shouldBe` JsonCursorString + it "initialises to beginning of array" $ do + let cursor = "[]" :: JsonCursor BS.ByteString t u + jsonCursorType cursor `shouldBe` JsonCursorArray + it "initialises to beginning of boolean true" $ do + let cursor = "true" :: JsonCursor BS.ByteString t u + jsonCursorType cursor `shouldBe` JsonCursorBool + it "initialises to beginning of boolean false" $ do + let cursor = "false" :: JsonCursor BS.ByteString t u + jsonCursorType cursor `shouldBe` JsonCursorBool + it "initialises to beginning of null" $ do + let cursor = "null" :: JsonCursor BS.ByteString t u + jsonCursorType cursor `shouldBe` JsonCursorNull + it "cursor can navigate to first child of array" $ do + let cursor = "[null]" :: JsonCursor BS.ByteString t u + jsonCursorType (fc cursor) `shouldBe` JsonCursorNull + it "cursor can navigate to second child of array" $ do + let cursor = "[null, {\"field\": 1}]" :: JsonCursor BS.ByteString t u + jsonCursorType ((ns . fc) cursor) `shouldBe` JsonCursorObject + it "cursor can navigate to first child of object at second child of array" $ do + let cursor = "[null, {\"field\": 1}]" :: JsonCursor BS.ByteString t u + jsonCursorType ((fc . ns . fc) cursor) `shouldBe` JsonCursorString + it "cursor can navigate to first child of object at second child of array" $ do + let cursor = "[null, {\"field\": 1}]" :: JsonCursor BS.ByteString t u + jsonCursorType ((ns . fc . ns . fc) cursor) `shouldBe` JsonCursorNumber + it "depth at top" $ do + let cursor = "[null]" :: JsonCursor BS.ByteString t u + cd cursor `shouldBe` 1 + it "depth at first child of array" $ do + let cursor = "[null]" :: JsonCursor BS.ByteString t u + cd (fc cursor) `shouldBe` 2 + it "depth at second child of array" $ do + let cursor = "[null, {\"field\": 1}]" :: JsonCursor BS.ByteString t u + cd ((ns . fc) cursor) `shouldBe` 2 + it "depth at first child of object at second child of array" $ do + let cursor = "[null, {\"field\": 1}]" :: JsonCursor BS.ByteString t u + cd ((fc . ns . fc) cursor) `shouldBe` 3 + it "depth at first child of object at second child of array" $ do + let cursor = "[null, {\"field\": 1}]" :: JsonCursor BS.ByteString t u + cd ((ns . fc . ns . fc) cursor) `shouldBe` 3 + it "can navigate down and forwards" $ do + (fptr, offset, size) <- mmapFileForeignPtr "test/data/sample.json" ReadOnly Nothing + let cursor = fromForeignRegion (fptr, offset, size) :: JsonCursor BS.ByteString t u + jsonCursorType cursor `shouldBe` JsonCursorObject + jsonCursorType (( fc) cursor) `shouldBe` JsonCursorString + jsonCursorType (( ns . fc) cursor) `shouldBe` JsonCursorObject + jsonCursorType (( fc . ns . fc) cursor) `shouldBe` JsonCursorString + jsonCursorType (( ns . fc . ns . fc) cursor) `shouldBe` JsonCursorString + jsonCursorType (( ns . ns . fc . ns . fc) cursor) `shouldBe` JsonCursorString + jsonCursorType (( ns . ns . ns . fc . ns . fc) cursor) `shouldBe` JsonCursorObject + jsonCursorType (( fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` JsonCursorString + jsonCursorType (( ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` JsonCursorString + jsonCursorType (( ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` JsonCursorString + jsonCursorType (( ns . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` JsonCursorString + jsonCursorType (( ns . ns . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` JsonCursorString + jsonCursorType ((ns . ns . ns . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` JsonCursorNumber + it "can navigate up" $ do + (fptr, offset, size) <- mmapFileForeignPtr "test/data/sample.json" ReadOnly Nothing + let cursor = fromForeignRegion (fptr, offset, size) :: JsonCursor BS.ByteString t u + ( pn . fc) cursor `shouldBe` cursor + ( pn . ns . fc) cursor `shouldBe` cursor + ( pn . fc . ns . fc) cursor `shouldBe` ( ns . fc) cursor + ( pn . ns . fc . ns . fc) cursor `shouldBe` ( ns . fc) cursor + ( pn . ns . ns . fc . ns . fc) cursor `shouldBe` ( ns . fc) cursor + ( pn . ns . ns . ns . fc . ns . fc) cursor `shouldBe` ( ns . fc) cursor + ( pn . fc . ns . ns . ns . fc . ns . fc) cursor `shouldBe` (ns . ns . ns . fc . ns . fc) cursor + ( pn . ns . fc . ns . ns . ns . fc . ns . fc) cursor `shouldBe` (ns . ns . ns . fc . ns . fc) cursor + ( pn . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor `shouldBe` (ns . ns . ns . fc . ns . fc) cursor + ( pn . ns . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor `shouldBe` (ns . ns . ns . fc . ns . fc) cursor + ( pn . ns . ns . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor `shouldBe` (ns . ns . ns . fc . ns . fc) cursor + ( pn . ns . ns . ns . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor `shouldBe` (ns . ns . ns . fc . ns . fc) cursor + it "can get subtree size" $ do + (fptr, offset, size) <- mmapFileForeignPtr "test/data/sample.json" ReadOnly Nothing + let cursor = fromForeignRegion (fptr, offset, size) :: JsonCursor BS.ByteString t u + ss cursor `shouldBe` 45 + ss (( fc) cursor) `shouldBe` 1 + ss (( ns . fc) cursor) `shouldBe` 43 + ss (( fc . ns . fc) cursor) `shouldBe` 1 + ss (( ns . fc . ns . fc) cursor) `shouldBe` 1 + ss (( ns . ns . fc . ns . fc) cursor) `shouldBe` 1 + ss (( ns . ns . ns . fc . ns . fc) cursor) `shouldBe` 9 + ss (( fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` 1 + ss (( ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` 1 + ss (( ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` 1 + ss (( ns . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` 1 + ss (( ns . ns . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` 1 + ss ((ns . ns . ns . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` 1 + it "can get token at cursor" $ do + (fptr, offset, size) <- mmapFileForeignPtr "test/data/sample.json" ReadOnly Nothing + let cursor = fromForeignRegion (fptr, offset, size) :: JsonCursor BS.ByteString t u + jsonTokenAt cursor `shouldBe` Just (JsonTokenBraceL ) + jsonTokenAt (( fc) cursor) `shouldBe` Just (JsonTokenString "widget" ) + jsonTokenAt (( ns . fc) cursor) `shouldBe` Just (JsonTokenBraceL ) + jsonTokenAt (( fc . ns . fc) cursor) `shouldBe` Just (JsonTokenString "debug" ) + jsonTokenAt (( ns . fc . ns . fc) cursor) `shouldBe` Just (JsonTokenString "on" ) + jsonTokenAt (( ns . ns . fc . ns . fc) cursor) `shouldBe` Just (JsonTokenString "window" ) + jsonTokenAt (( ns . ns . ns . fc . ns . fc) cursor) `shouldBe` Just (JsonTokenBraceL ) + jsonTokenAt (( fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` Just (JsonTokenString "title" ) + jsonTokenAt (( ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` Just (JsonTokenString "Sample Konfabulator Widget") + jsonTokenAt (( ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` Just (JsonTokenString "name" ) + jsonTokenAt (( ns . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` Just (JsonTokenString "main_window" ) + jsonTokenAt (( ns . ns . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` Just (JsonTokenString "width" ) + jsonTokenAt ((ns . ns . ns . ns . ns . fc . ns . ns . ns . fc . ns . fc) cursor) `shouldBe` Just (JsonTokenNumber 500.0 ) diff --git a/test/HaskellWorks/Data/Json/Token/TokenizeSpec.hs b/test/HaskellWorks/Data/Json/Token/TokenizeSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Json/Token/TokenizeSpec.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HaskellWorks.Data.Json.Token.TokenizeSpec (spec) where + +import qualified Data.Attoparsec.ByteString.Char8 as BC +import Data.ByteString as BS +import HaskellWorks.Data.Json.Token.Tokenize +import Test.Hspec + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} + +parseJsonToken' :: ByteString -> Either String (JsonToken String Double) +parseJsonToken' = BC.parseOnly parseJsonToken + +spec :: Spec +spec = describe "Data.Conduit.Succinct.JsonSpec" $ do + describe "When parsing single token at beginning of text" $ do + it "Empty Json should produce no bits" $ + parseJsonToken' "" `shouldBe` Left "not enough input" + it "Json with one space should produce whitespace token" $ + parseJsonToken' " " `shouldBe` Right JsonTokenWhitespace + it "Json with two spaces should produce whitespace token" $ + parseJsonToken' " " `shouldBe` Right JsonTokenWhitespace + it "Spaces and newlines should produce no bits" $ + parseJsonToken' " \n \r \t " `shouldBe` Right JsonTokenWhitespace + it "`null` at beginning should produce one bit" $ + parseJsonToken' "null " `shouldBe` Right JsonTokenNull + it "number at beginning should produce one bit" $ + parseJsonToken' "1234 " `shouldBe` Right (JsonTokenNumber 1234) + it "false at beginning should produce one bit" $ + parseJsonToken' "false " `shouldBe` Right (JsonTokenBoolean False) + it "true at beginning should produce one bit" $ + parseJsonToken' "true " `shouldBe` Right (JsonTokenBoolean True) + it "string at beginning should produce one bit" $ + parseJsonToken' "\"hello\" " `shouldBe` Right (JsonTokenString "hello") + it "quoted string should parse" $ + parseJsonToken' "\"\\\"\" " `shouldBe` Right (JsonTokenString "\"") + it "left brace at beginning should produce one bit" $ + parseJsonToken' "{ " `shouldBe` Right JsonTokenBraceL + it "right brace at beginning should produce one bit" $ + parseJsonToken' "} " `shouldBe` Right JsonTokenBraceR + it "left bracket at beginning should produce one bit" $ + parseJsonToken' "[ " `shouldBe` Right JsonTokenBracketL + it "right bracket at beginning should produce one bit" $ + parseJsonToken' "] " `shouldBe` Right JsonTokenBracketR + it "right bracket at beginning should produce one bit" $ + parseJsonToken' ": " `shouldBe` Right JsonTokenColon + it "right bracket at beginning should produce one bit" $ + parseJsonToken' ", " `shouldBe` Right JsonTokenComma diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/data/sample.json b/test/data/sample.json new file mode 100644 --- /dev/null +++ b/test/data/sample.json @@ -0,0 +1,28 @@ +{ + "widget": { + "debug": "on", + "window": { + "title": "Sample Konfabulator Widget", + "name": "main_window", + "width": 500, + "height": 500 + }, + "image": { + "src": "Images/Sun.png", + "name": "sun1", + "hOffset": 250, + "vOffset": 250, + "alignment": "center" + }, + "text": { + "data": "Click Here", + "size": 36, + "style": "bold", + "name": "text1", + "hOffset": 250, + "vOffset": 100, + "alignment": "center", + "onMouseUp": "sun1.opacity = (sun1.opacity / 100) * 90;" + } + } +}