diff --git a/Data/JsonStream/Parser.hs b/Data/JsonStream/Parser.hs --- a/Data/JsonStream/Parser.hs +++ b/Data/JsonStream/Parser.hs @@ -4,6 +4,9 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} -- | -- Module : Data.JsonStream.Parser @@ -16,7 +19,7 @@ -- An incremental applicative-style JSON parser, suitable for high performance -- memory efficient stream parsing. -- --- The parser is using "Data.Aeson" types and 'FromJSON' instance, it can be +-- The parser is optionally using "Data.Aeson" types and 'FromJSON' instance, it can be -- easily combined with aeson monadic parsing instances when appropriate. module Data.JsonStream.Parser ( @@ -72,25 +75,24 @@ , arrayWithIndexOf , indexedArrayOf , nullable + -- * Fast structure parser + , objectOf + , Object -- * Parsing modifiers , filterI , takeI , mapWithFailure , manyReverse + , foldI + , foldMapI + , unFoldI + , catMaybeI -- * SAX-like parsers , arrayFound , objectFound ) where -#if !MIN_VERSION_bytestring(0,10,6) -import Data.Monoid (Monoid, mappend, mempty) -#endif - -#if MIN_VERSION_base(4,10,0) -import Data.Semigroup (Semigroup(..)) -#endif - -import Control.Applicative +import Control.Applicative ( Alternative(..), optional ) import qualified Data.Aeson as AE import qualified Data.Aeson.Types as AE import qualified Data.ByteString.Char8 as BS @@ -108,11 +110,13 @@ toBoundedInteger, toRealFloat) import qualified Data.Text as T import qualified Data.Vector as Vec -import Foreign.C.Types +import Foreign.C.Types ( CLong ) -import Data.JsonStream.CLexer -import Data.JsonStream.TokenParser +import Data.JsonStream.CLexer ( unescapeText, tokenParser ) +import Data.JsonStream.TokenParser ( TokenResult(..), Element(..) ) import Data.JsonStream.Unescape (unsafeDecodeASCII) +import qualified Data.Map.Strict as Map +import Unsafe.Coerce (unsafeCoerce) -- | Limit for the size of an object key objectKeyStringLimit :: Int @@ -183,17 +187,11 @@ -- >>> let parser = arrayOf $ "key1" .: (arrayOf value) <> "key2" .: (arrayOf value) -- >>> parseByteString parser test :: [Int] -- [1,2,5,6] -#if MIN_VERSION_base(4,10,0) instance Monoid (Parser a) where mempty = ignoreVal mappend = (<>) instance Semigroup (Parser a) where (<>) m1 m2 = -#else -instance Monoid (Parser a) where - mempty = ignoreVal - mappend m1 m2 = -#endif Parser $ \tok -> process (callParse m1 tok) (callParse m2 tok) where process (Yield v np1) p2 = Yield v (process np1 p2) @@ -258,7 +256,7 @@ (PartialResult ArrayBegin ntp) -> moreData (nextitem 0) ntp (PartialResult _ _) -> callParse ignoreVal tp -- Run ignoreval parser on the same output we got (TokMoreData ntok) -> MoreData (array' valparse, ntok) - (TokFailed) -> Failed "Array - token failed" + TokFailed -> Failed "Array - token failed" where nextitem !_ _ (ArrayEnd ctx) ntok = Done ctx ntok nextitem !i tok _ _ = arrcontent i (callParse (valparse i) tok) @@ -320,7 +318,7 @@ (PartialResult ObjectBegin ntp) -> moreData (nextitem False) ntp (PartialResult _ _) -> callParse ignoreVal tp -- Run ignoreval parser on the same output we got (TokMoreData ntok) -> MoreData (object' once valparse, ntok) - TokFailed -> Failed "Array - token failed" + TokFailed -> Failed "Object - token failed" where nextitem _ _ (ObjectEnd ctx) ntok = Done ctx ntok nextitem yielded _ (JValue (AE.String key)) ntok = @@ -354,7 +352,7 @@ | otherwise -> moreData (getLongKey (str:acc) (len + BS.length str)) ntok _ -> Failed "Object longstr - lexer failed." --- | Helper function to deduplicate TokMoreData/FokFailed logic +-- | Helper function to deduplicate TokMoreData/TokFailed logic moreData :: (TokenResult -> Element -> TokenResult -> ParseResult v) -> TokenResult -> ParseResult v moreData parser tok = case tok of @@ -551,7 +549,7 @@ jNull :: Parser () jNull = jvalue cvt (const Nothing) where - cvt (AE.Null) = Just () + cvt AE.Null = Just () cvt _ = Nothing -- | Parses a field with a possible null value. @@ -651,6 +649,39 @@ | cond v = Yield v (loop np) | otherwise = loop np +-- | Fold over values in stream +foldI :: (b -> a -> b) -> b -> Parser a -> Parser b +foldI mfold start f = Parser $ \ntok -> loop start (callParse f ntok) + where + loop !acc (Done ctx ntp) = Yield acc (Done ctx ntp) + loop !acc (MoreData (Parser np, ntok)) = MoreData (Parser (loop acc . np), ntok) + loop !acc (Yield v np) = loop (acc `mfold` v) np + loop _ (Failed err) = Failed err + +-- | Strict foldMap over values in stream +foldMapI :: Monoid m => (a -> m) -> Parser a -> Parser m +foldMapI f = foldI (\b a -> b <> f a) mempty + +-- | Filter Nothing values out of a stream +catMaybeI :: Parser (Maybe a) -> Parser a +catMaybeI valparse = Parser $ \ntok -> loop (callParse valparse ntok) + where + loop (Done ctx ntp) = Done ctx ntp + loop (Failed err) = Failed err + loop (MoreData (Parser np, ntok)) = MoreData (Parser (loop . np), ntok) + loop (Yield (Just v) np) = Yield v (loop np) + loop (Yield Nothing np) = loop np + +-- | From a list of values generate single values +unFoldI :: Parser [a] -> Parser a +unFoldI valparse = Parser $ \ntok -> loop (callParse valparse ntok) + where + loop (Done ctx ntp) = Done ctx ntp + loop (Failed err) = Failed err + loop (MoreData (Parser np, ntok)) = MoreData (Parser (loop . np), ntok) + loop (Yield (v:rest) np) = Yield v (loop (Yield rest np)) + loop (Yield [] np) = loop np + -- | A back-door for lifting of possibly failing actions. -- If an action fails with Left value, convert it into failure -- of parsing @@ -669,35 +700,57 @@ --- Convenience operators --- | Synonym for 'objectWithKey'. Matches key in an object. The '.:' operators can be chained. --- --- >>> let json = "{\"key1\": {\"nested-key\": 3}}" --- >>> parseByteString ("key1" .: "nested-key" .: integer) json :: [Int] --- [3] -(.:) :: T.Text -> Parser a -> Parser a -(.:) = objectWithKey -infixr 7 .: +class OnObject o a where + -- | Synonym for 'objectWithKey'. The '.:' operators can be chained. + -- + -- >>> let json = "{\"key1\": {\"nested-key\": 3}}" + -- >>> parseByteString ("key1" .: "nested-key" .: integer) json :: [Int] + -- > [3] + -- + -- It works both as a standalone parser and as a part of 'objectOf' parser + -- + -- >>> let test = "[{\"name\": \"test1\", \"value\": 1}, {\"name\": \"test2\", \"value\": null}, {\"name\": \"test3\"}]" + -- >>> let person = objectOf $ (,) <$> "name" .: string <*> "value" .: integer .| (-1) + -- >>> let people = arrayOf person + -- >>> parseByteString people test :: [(T.Text, Int)] + -- [("test1",1),("test2",-1),("test3",-1)] --- | Returns 'Nothing' if value is null or does not exist or match. Otherwise returns 'Just' value. --- --- > key .:? val = optional (key .: val) -(.:?) :: T.Text -> Parser a -> Parser (Maybe a) -key .:? val = optional (key .: val) -infixr 7 .:? + (.:) :: T.Text -> Parser a -> o a + -- | Returns 'Nothing' if value is null or does not exist or match. Otherwise returns 'Just' value. + -- + -- > key .:? val = optional (key .: val) + -- + -- It could be similarly used in the 'objectOf' parser + (.:?) :: T.Text -> Parser a -> o (Maybe a) --- | Return default value if the parsers on the left hand didn't produce a result. --- --- > p .| defval = p <|> pure defval --- --- The operator works on complete left side, the following statements are equal: --- --- > Record <$> "key1" .: "nested-key" .: value .| defaultValue --- > Record <$> (("key1" .: "nested-key" .: value) .| defaultValue) -(.|) :: Parser a -> a -> Parser a -p .| defval = p <|> pure defval + -- | Return default value if the parsers on the left hand didn't produce a result. + -- + -- > p .| defval = p <|> pure defval + -- + -- The operator works on complete left side, the following statements are equal: + -- + -- > Record <$> "key1" .: "nested-key" .: value .| defaultValue + -- > Record <$> (("key1" .: "nested-key" .: value) .| defaultValue) + (.|) :: o a -> a -> o a + +infixr 7 .: +infixr 7 .:? infixl 6 .| +instance OnObject Parser a where + (.:) = objectWithKey + key .:? val = optional (key .: val) + p .| defval = p <|> pure defval +instance OnObject Object a where + (.:) = fastObjectWithKey + (.:?) = fastObjectWithKeyMaybe + (Object pmap out) .| defval = Object pmap altFunc + where + altFunc dmap = case out dmap of + [] -> [defval] + res -> res + -- | Synonym for 'arrayWithIndexOf'. Matches n-th item in array. -- -- >>> parseByteString (arrayOf (1 .! bool)) "[ [1,true,null], [2,false], [3]]" :: [Bool] @@ -802,6 +855,86 @@ | BS.all isSpace rest = Right v checkExit _ _ = Left "Data folowed by non-whitespace characters." +--- High performance object parsing + +-- | Representation for applicative JSON one-pass object parsing +data Object f = Object + (Map.Map T.Text (Parser ())) -- ^ Field parsers + (Map.Map T.Text [()] -> [f]) -- ^ How to generate results from already parsed fields + deriving (Functor) + +-- We use unsafeCoerce to convert to () and back; we guarantee that there exists only +-- one key to the map and so the original Parser will get the right type of value. +-- This allows to drop the Typeable constraint, but the code better be OK here. + +instance Applicative Object where + pure f = Object mempty (const (pure f)) + (Object amap adata) <*> (Object bmap bdata) = + let dmap = Map.unionWithKey (\k _ _ -> error ("JStream Object - duplicate field access: " <> T.unpack k)) amap bmap + in dmap `seq` Object dmap dfunc + where + dfunc dmap = ($) <$> adata dmap <*> bdata dmap + +instance Alternative Object where + empty = Object mempty (const []) + (Object amap adata) <|> (Object bmap bdata) = + let dmap = Map.unionWithKey (\k _ _ -> error ("JStream Object - duplicate field access: " <> T.unpack k)) amap bmap + in dmap `seq` Object dmap dfunc + where + -- Return second one if first one generates nothing + dfunc dmap = + case adata dmap of + [] -> bdata dmap + lst -> lst + +instance Semigroup (Object a) where + (Object amap adata) <> (Object bmap bdata) = + let dmap = Map.unionWithKey (\k _ _ -> error ("JStream Object - duplicate field access: " <> T.unpack k)) amap bmap + in dmap `seq` Object dmap dfunc + where + -- Return second one if first one generates nothing + dfunc dmap = adata dmap <> bdata dmap + +-- | Similar to 'objectWithKey', generates a field-accessor in JSON object +fastObjectWithKey :: forall a. T.Text -> Parser a -> Object a +fastObjectWithKey tname parser = Object (Map.singleton tname parseObj) mkObj + where + mkObj dmap = case unsafeCoerce <$> Map.lookup tname dmap of + Just (vals :: [a]) -> reverse vals + Nothing -> [] + parseObj = unsafeCoerce <$> parser + +fastObjectWithKeyMaybe :: forall a. T.Text -> Parser a -> Object (Maybe a) +fastObjectWithKeyMaybe tname parser = Object (Map.singleton tname parseObj) mkObj + where + mkObj dmap = case unsafeCoerce <$> Map.lookup tname dmap of + Just (vals :: [a]) -> Just <$> reverse vals + Nothing -> [Nothing] + parseObj = unsafeCoerce <$> parser + +-- | Parser for faster object parsing +-- +-- The whole object is parsed in a single run. Use the '.:' combinator to +-- access the fields; you may not access the same field more than once. If you +-- try to access the same field, an 'error' is called. +-- +-- The operators '.:', '.:?', '<|>' and '<>' are supported and will produce +-- the same results as if used directly with parallel parsing. +objectOf :: forall f. Object f -> Parser f +objectOf (Object pmap odata) = + unFoldI $ odata <$> foldResults (object' False parseKey) + where + foldResults :: Parser (T.Text, ()) -> Parser (Map.Map T.Text [()]) + foldResults = foldI (\bmap (k,v) -> Map.alter (addVal v) k bmap) mempty + where + addVal v Nothing = Just [v] + addVal v (Just old) = Just (v:old) + + parseKey :: T.Text -> Parser (T.Text, ()) + parseKey key = case Map.lookup key pmap of + Nothing -> ignoreVal + Just p -> (key,) <$> p + -- $use -- -- >>> parseByteString value "[1,2,3]" :: [[Int]] @@ -838,7 +971,7 @@ -- -- The 'value' parser works by creating an aeson AST and passing it to the -- 'parseJSON' method. The AST can consume a lot of memory before it is rejected --- in 'parseJSON'. To achieve constant space the parsers 'safeString', 'number', 'integer', +-- in 'parseJSON'. To achieve constant space the parsers 'safeString', 'objectOf', 'number', 'integer', -- 'real' and 'bool' -- must be used; these parsers reject and do not parse data if it does not match the -- type. @@ -856,6 +989,9 @@ -- '.!' and '.:' functions combined with constant space -- parsers or limiting the number of returned elements with 'takeI'. -- +-- Running many parallel parsers (e.g. when parsing objects with a lot of fields) will slow +-- things done. Use the 'objectOf'. +-- -- If the source object contains an object with multiple keys with a same name, -- json-stream matches the key multiple times. The only exception -- is 'objectWithKey' ('.:' and '.:?') that return at most one value for a given key. @@ -875,19 +1011,32 @@ -- >>> let people = arrayOf person -- >>> parseByteString people test :: [(T.Text, Int)] -- [("test1",1),("test2",-1),("test3",-1)] - +-- +-- The above code would run 3 parsers in parallel to get the appropriate results. +-- You can use the 'objectOf' parser to get a similar result in a more performant way. +-- +-- >>> let test = "[{\"name\": \"test1\", \"value\": 1}, {\"name\": \"test2\", \"value\": null}, {\"name\": \"test3\"}]" +-- >>> let person = objectOf $ (,) <$> "name" .: string <*> "value" .: integer .| (-1) +-- >>> let people = arrayOf person +-- >>> parseByteString people test :: [(T.Text, Int)] +-- [("test1",1),("test2",-1),("test3",-1)] +-- -- $performance -- The parser tries to do the least amount of work to get the job done, skipping over items that -- are not required. General guidelines to get best performance: -- --- Do not use the 'value' parser for the whole object if the object is big. Do not use json-stream --- applicative parsing for creating objects if they have lots of records, unless you are skipping --- large part of the structure. Every '<*>' causes parallel parsing, too many parallel parsers --- kill performance. +-- Do not use the 'value' parser for the whole object if the object is big. +-- Consider using the 'objectOf' parser to parse objects instead of direct applicative parsing +-- for creating objects if they have lots of records. Every '<*>' outside of direct 'objectOf' parser +-- causes parallel parsing. Too many parallel parsers kill performance. -- +-- > arrayOf $ objectOf $ MyStructure <$> "field1" .: string <*> "field2" .: integer <*> .... <*> "field20" .: string +-- +-- will be the fastest and use the least memory. +-- -- > arrayOf value :: Parser MyStructure -- MyStructure with FromJSON instance -- --- will probably behave better than +-- will probably still behave better than -- -- > arrayOf $ MyStructure <$> "field1" .: string <*> "field2" .: integer <*> .... <*> "field20" .: string -- diff --git a/Data/JsonStream/Unescape.hs b/Data/JsonStream/Unescape.hs --- a/Data/JsonStream/Unescape.hs +++ b/Data/JsonStream/Unescape.hs @@ -2,9 +2,7 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnliftedFFITypes #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE PatternGuards #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} module Data.JsonStream.Unescape ( unescapeText diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -127,21 +127,28 @@ >>> let test = "[{\"name\": \"John\", \"age\": 20}, {\"age\": 30, \"name\": \"Frank\"} ]" >>> let parser = arrayOf $ (,) <$> "name" .: value <*> "age" .: value ->>> parseByteString parser test :: [(Text,Int)] +>>> parseByteString parser test :: [(Text,Int)] [("John",20),("Frank",30)] +-- Use objectOf for parsing objects (it's faster than parallel parsing). +>>> let test = "[{\"name\": \"John\", \"age\": 20}, {\"age\": 30, \"name\": \"Frank\"} ]" +>>> let parser = arrayOf $ objectOf $ (,) <$> "name" .: value + <*> "age" .: value +>>> parseByteString parser test :: [(Text,Int)] +[("John",20),("Frank",30)] + -- If you have more results returned from each branch, all are combined. >>> let test = "[{\"key1\": [1,2], \"key2\": [5,6], \"key3\": [8,9]}]" >>> let parser = arrayOf $ (,) <$> "key2" .: (arrayOf value) <*> "key1" .: (arrayOf value) ->>> parse parser test :: [(Int, Int)] +>>> parseByteString parser test :: [(Int, Int)] [(6,2),(6,1),(5,2),(5,1)] -- Use <> to return both branches let test = "[{\"key1\": [1,2], \"key2\": [5,6], \"key3\": [8,9]}]" >>> let parser = arrayOf $ "key1" .: (arrayOf value) <> "key2" .: (arrayOf value) ->>> parse parser test :: [Int] +>>> parseByteString parser test :: [Int] [1,2,5,6] -- objectItems function enriches value with object key @@ -152,12 +159,19 @@ [("key1",1),("key1",2),("key1",3),("key2",5),("key2",6),("key2",7)] -- .:? produces a maybe value; Nothing if match is not found or is null. --- .!= converts Maybe back with a default ->>> let test = "[{\"name\":\"John\", \"value\": 12}, {\"name\":\"name2\"}]" ->>> let parser = arrayOf $ (,) <$> "name" .: string - <*> "value" .:? integer .!= 0 ->>> parseByteString parser test :: [(String,Int)] -[("John",12),("name2",0)] +-- .| produces a default value if the preceding didn't produce anything +>>> let test = "[{\"name\":\"John\", \"value\": 12}, {\"name\":\"name2\"}, {\"value\":12}]" +>>> let parser = arrayOf $ (,) <$> "name" .:? string + <*> "value" .: integer .| 0 +>>> parseByteString parser test :: [(Maybe Text, Int)] +[(Just "John",12),(Just "name2",0),(Nothing,12)] + +-- And it works the same with the objectOf parser +>>> let test = "[{\"name\":\"John\", \"value\": 12}, {\"name\":\"name2\"}, {\"value\":12}]" +>>> let parser = arrayOf $ objectOf $ (,) <$> "name" .:? string + <*> "value" .: integer .| 0 +>>> parseByteString parser test :: [(Maybe Text, Int)] +[(Just "John",12),(Just "name2",0),(Nothing,12)] ``` diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,8 @@ +# 0.4.5.0 + +- objectOf parser for faster one-pass JSON object parsing +- set minimum base to 4.11 + # 0.4.4.2 - aeson-2.1 diff --git a/json-stream.cabal b/json-stream.cabal --- a/json-stream.cabal +++ b/json-stream.cabal @@ -1,5 +1,5 @@ name: json-stream -version: 0.4.4.2 +version: 0.4.5.0 synopsis: Incremental applicative JSON parser description: Easy to use JSON parser fully supporting incremental parsing. Parsing grammar in applicative form. @@ -11,8 +11,6 @@ of the input data. In addition to performance-critical parts written in C, a lot of performance is gained by being less memory intensive especially when used for stream parsing. - . - * WARNING: 0.4.0.0 has code-breaking semantic changes, see changelog! homepage: https://github.com/ondrap/json-stream license: BSD3 @@ -42,12 +40,13 @@ c-sources: c_lib/lexer.c, c_lib/unescape_string.c includes: c_lib/lexer.h include-dirs: c_lib - build-depends: base >=4.7 && <5 + build-depends: base >=4.11 && <5 , bytestring , text , aeson >= 0.7 && < 2.2 , vector , unordered-containers + , containers , scientific , primitive if flag(conduit) @@ -72,7 +71,7 @@ includes: c_lib/lexer.h include-dirs: c_lib cc-options: -fPIC - Build-Depends: base >= 4.7 && <5 + Build-Depends: base >= 4.11 && <5 , doctest >= 0.9.3 , bytestring , text @@ -101,7 +100,7 @@ hs-source-dirs: test, . default-language: Haskell2010 ghc-options: -Wall - build-depends: base >=4.7 && <5 + build-depends: base >=4.11 && <5 , bytestring , text , aeson @@ -122,7 +121,7 @@ -- c-sources: c_lib/lexer.c -- include-dirs: c_lib -- default-language: Haskell2010 --- build-depends: base >=4.7 && <5 +-- build-depends: base >=4.11 && <5 -- , bytestring -- , text -- , aeson