diff --git a/hw-json.cabal b/hw-json.cabal --- a/hw-json.cabal +++ b/hw-json.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: hw-json -version: 1.2.0.1 +version: 1.2.0.2 synopsis: Memory efficient JSON parser description: Memory efficient JSON parser. Please see README.md category: Data @@ -39,6 +39,7 @@ common base { build-depends: base >= 4 && < 5 } +common aeson { build-depends: aeson >= 1.4.3.0 && < 1.5 } common ansi-wl-pprint { build-depends: ansi-wl-pprint >= 0.6.8.2 && < 0.7 } common array { build-depends: array >= 0.5 && < 0.6 } common attoparsec { build-depends: attoparsec >= 0.13 && < 0.14 } @@ -55,7 +56,7 @@ common hw-hspec-hedgehog { build-depends: hw-hspec-hedgehog >= 0.1.0.4 && < 0.2 } common hw-json-simd { build-depends: hw-json-simd >= 0.1.0.2 && < 0.2 } common hw-json-simple-cursor { build-depends: hw-json-simple-cursor >= 0.1.0.1 && < 0.2 } -common hw-json-standard-cursor { build-depends: hw-json-standard-cursor >= 0.1.0.1 && < 0.2 } +common hw-json-standard-cursor { build-depends: hw-json-standard-cursor >= 0.1.1.0 && < 0.2 } common hw-mquery { build-depends: hw-mquery >= 0.2.0.0 && < 0.3 } common hw-parser { build-depends: hw-parser >= 0.1 && < 0.2 } common hw-prim { build-depends: hw-prim >= 0.6.2.28 && < 0.7 } @@ -65,6 +66,7 @@ common lens { build-depends: lens >= 4 && < 5 } common mmap { build-depends: mmap >= 0.5 && < 0.6 } common optparse-applicative { build-depends: optparse-applicative >= 0.14 && < 0.15 } +common scientific { build-depends: scientific >= 0.3.6.2 && < 0.4 } common text { build-depends: text >= 1.2 && < 1.3 } common transformers { build-depends: transformers >= 0.4 && < 0.6 } common vector { build-depends: vector >= 0.12 && < 0.13 } @@ -83,6 +85,7 @@ library import: base, config + , aeson , ansi-wl-pprint , attoparsec , bits-extra @@ -160,6 +163,7 @@ test-suite hw-json-test import: base, config + , aeson , attoparsec , bytestring , hedgehog @@ -172,6 +176,8 @@ , hw-prim , hw-rankselect , hw-rankselect-base + , scientific + , text , transformers , vector type: exitcode-stdio-1.0 @@ -181,6 +187,7 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-tools: hspec-discover other-modules: + HaskellWorks.Data.Json.LightJsonSpec HaskellWorks.Data.Json.Simple.CursorSpec HaskellWorks.Data.Json.Standard.CursorSpec HaskellWorks.Data.Json.Standard.GenCursorTest diff --git a/src/HaskellWorks/Data/Json/Internal/Slurp.hs b/src/HaskellWorks/Data/Json/Internal/Slurp.hs --- a/src/HaskellWorks/Data/Json/Internal/Slurp.hs +++ b/src/HaskellWorks/Data/Json/Internal/Slurp.hs @@ -13,10 +13,12 @@ import HaskellWorks.Data.Json.Standard.Cursor.Internal.Word8 import Prelude hiding (drop) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BSC -import qualified Data.List as L -import qualified Data.Text as T +import qualified Data.Aeson.Parser.Internal as AP +import qualified Data.Attoparsec.ByteString as PBS +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.List as L +import qualified Data.Text as T data JsonState = Escaped @@ -25,22 +27,10 @@ | InNumber | InIdent -slurpText :: BS.ByteString -> Text -slurpText bs = T.pack $ L.unfoldr genString (InJson, BSC.unpack bs) -- TODO optimise - where genString :: (JsonState, String) -> Maybe (Char, (JsonState, String)) - genString (InJson, ds) = case ds of - (e:es) | e == '"' -> genString (InString , es) - (_:es) -> genString (InJson , es) - _ -> Nothing - genString (InString, ds) = case ds of - (e:es) | e == '\\' -> genString (Escaped , es) - (e:_ ) | e == '"' -> Nothing - (e:es) -> Just (e, (InString , es)) - _ -> Nothing - genString (Escaped, ds) = case ds of - (_:es) -> Just ('.', (InString , es)) - _ -> Nothing - genString (_, _) = Nothing +slurpText :: BS.ByteString -> Either Text Text +slurpText bs = case PBS.parseOnly AP.jstring bs of + Right t -> Right t + Left e -> Left (T.pack e) slurpNumber :: BS.ByteString -> BS.ByteString slurpNumber bs = let (!cs, _) = BS.unfoldrN (BS.length bs) genNumber (InJson, bs) in cs diff --git a/src/HaskellWorks/Data/Json/LightJson.hs b/src/HaskellWorks/Data/Json/LightJson.hs --- a/src/HaskellWorks/Data/Json/LightJson.hs +++ b/src/HaskellWorks/Data/Json/LightJson.hs @@ -31,7 +31,6 @@ import HaskellWorks.Data.TreeCursor import HaskellWorks.Data.Uncons import Prelude hiding (drop) -import Prelude hiding (drop) import Text.PrettyPrint.ANSI.Leijen import qualified Data.ByteString as BS @@ -126,7 +125,7 @@ instance (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => LightJsonAt (GenericCursor BS.ByteString v w) where lightJsonAt k = case uncons remainder of Just (!c, _) | isLeadingDigit2 c -> LightJsonNumber (slurpNumber remainder) - Just (!c, _) | isQuotDbl c -> LightJsonString (slurpText remainder) + Just (!c, _) | isQuotDbl c -> either LightJsonError LightJsonString (slurpText remainder) Just (!c, _) | isChar_t c -> LightJsonBool True Just (!c, _) | isChar_f c -> LightJsonBool False Just (!c, _) | isChar_n c -> LightJsonNull diff --git a/test/HaskellWorks/Data/Json/LightJsonSpec.hs b/test/HaskellWorks/Data/Json/LightJsonSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Json/LightJsonSpec.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module HaskellWorks.Data.Json.LightJsonSpec (spec) where + +import Control.Monad +import Data.Text +import HaskellWorks.Data.BalancedParens.BalancedParens +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Json.DecodeError +import HaskellWorks.Data.Json.LightJson +import HaskellWorks.Data.Json.Standard.Cursor.Generic +import HaskellWorks.Data.Json.Value +import HaskellWorks.Data.RankSelect.Base.Rank0 +import HaskellWorks.Data.RankSelect.Base.Rank1 +import HaskellWorks.Data.RankSelect.Base.Select1 +import HaskellWorks.Hspec.Hedgehog +import Hedgehog +import Test.Hspec + +import qualified Data.Aeson.Parser.Internal as AP +import qualified Data.Attoparsec.ByteString as PBS +import qualified Data.ByteString as BS +import qualified Data.Scientific as S +import qualified Data.Text as T +import qualified HaskellWorks.Data.Json.Standard.Cursor.Fast as FAST +import qualified HaskellWorks.Data.Json.Standard.Cursor.Slow as SLOW +import qualified HaskellWorks.Data.TreeCursor as TC + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} +{-# ANN module ("HLint: ignore Redundant bracket" :: String) #-} + +fc = TC.firstChild +ns = TC.nextSibling + +spec :: Spec +spec = describe "HaskellWorks.Data.Json.LightJsonSpec" $ do + genSpec "DVS.Vector Word64" SLOW.fromString + genSpec "CsPoppy" FAST.fromString + +jsonValueVia :: forall t u. + ( BalancedParens u + , Rank0 u + , Rank1 u + , Select1 t + , TestBit u) + => Maybe (GenericCursor BS.ByteString t u) + -> Either DecodeError JsonValue +jsonValueVia mk = case mk of + Just k -> case lightJsonAt k of + LightJsonString t -> Right (JsonString t) + LightJsonNumber bs -> case PBS.parseOnly AP.scientific bs of + Right s -> Right (JsonNumber (S.toRealFloat s)) + Left msg -> Left (DecodeError msg) + LightJsonObject ps -> fmap JsonObject (traverse fields ps) + LightJsonArray cs -> fmap JsonArray (traverse elements cs) + LightJsonBool v -> Right (JsonBool v) + LightJsonNull -> Right JsonNull + LightJsonError msg -> Left (DecodeError (T.unpack msg)) + Nothing -> Left (DecodeError "No such element") + where fields :: (Text, GenericCursor BS.ByteString t u) -> Either DecodeError (Text, JsonValue) + fields (f, c) = (f,) <$> jsonValueVia (Just c) + elements :: GenericCursor BS.ByteString t u -> Either DecodeError JsonValue + elements c = jsonValueVia (Just c) + +genSpec :: forall t u. + ( Eq t + , Show t + , Select1 t + , Eq u + , Show u + , Rank0 u + , Rank1 u + , BalancedParens u + , TestBit u) + => String -> (String -> GenericCursor BS.ByteString t u) -> SpecWith () +genSpec t makeCursor = do + describe ("Json cursor of type " ++ t) $ do + let forJson s f = describe ("of value " ++ show s) (f (makeCursor s)) + forJson "{}" $ \cursor -> do + it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonObject []) + forJson " {}" $ \cursor -> do + it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonObject []) + forJson "1234" $ \cursor -> do + it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonNumber 1234) + forJson "\"Hello\"" $ \cursor -> do + it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonString "Hello") + forJson "[]" $ \cursor -> do + it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonArray []) + forJson "true" $ \cursor -> do + it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonBool True) + forJson "false" $ \cursor -> do + it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonBool False) + forJson "null" $ \cursor -> do + it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right JsonNull + forJson "[null]" $ \cursor -> do + it "should have correct value" $ requireTest $ jsonValueVia (Just cursor) === Right (JsonArray [JsonNull]) + it "should have correct value" $ requireTest $ jsonValueVia (fc cursor) === Right JsonNull + forJson "[null, {\"field\": 1}]" $ \cursor -> do + it "cursor can navigate to second child of array" $ requireTest $ do + jsonValueVia ((fc >=> ns) cursor) === Right ( JsonObject [("field", JsonNumber 1)] ) + jsonValueVia (Just cursor) === Right (JsonArray [JsonNull, JsonObject [("field", JsonNumber 1)]]) + describe "For empty json array" $ do + let cursor = makeCursor "[]" + it "can navigate down and forwards" $ requireTest $ do + jsonValueVia (Just cursor) === Right (JsonArray []) + describe "For empty json array" $ do + let cursor = makeCursor "[null]" + it "can navigate down and forwards" $ requireTest $ do + jsonValueVia (Just cursor) === Right (JsonArray [JsonNull]) + describe "For sample Json" $ do + let cursor = makeCursor "{ \ + \ \"widget\": { \ + \ \"debug\": \"on\", \ + \ \"window\": { \ + \ \"name\": \"main_window\", \ + \ \"dimensions\": [500, 600.01e-02, true, false, null] \ + \ } \ + \ } \ + \}" :: GenericCursor BS.ByteString t u + it "can navigate down and forwards" $ requireTest $ do + let array = JsonArray [JsonNumber 500, JsonNumber 600.01e-02, JsonBool True, JsonBool False, JsonNull] :: JsonValue + let object1 = JsonObject ([("name", JsonString "main_window"), ("dimensions", array)]) :: JsonValue + let object2 = JsonObject ([("debug", JsonString "on"), ("window", object1)]) :: JsonValue + let object3 = JsonObject ([("widget", object2)]) :: JsonValue + jsonValueVia (Just cursor) === Right object3 + jsonValueVia ((fc ) cursor) === Right (JsonString "widget" ) + jsonValueVia ((fc >=> ns ) cursor) === Right (object2 ) + jsonValueVia ((fc >=> ns >=> fc ) cursor) === Right (JsonString "debug" ) + jsonValueVia ((fc >=> ns >=> fc >=> ns ) cursor) === Right (JsonString "on" ) + jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns ) cursor) === Right (JsonString "window" ) + jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns ) cursor) === Right (object1 ) + jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc ) cursor) === Right (JsonString "name" ) + jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns ) cursor) === Right (JsonString "main_window" ) + jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns ) cursor) === Right (JsonString "dimensions" ) + jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns ) cursor) === Right (array ) + jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc ) cursor) === Right (JsonNumber 500 ) + jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns ) cursor) === Right (JsonNumber 600.01e-02 ) + jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns ) cursor) === Right (JsonBool True ) + jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns ) cursor) === Right (JsonBool False ) + jsonValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> ns) cursor) === Right JsonNull