diff --git a/Data/JsonStream/Parser.hs b/Data/JsonStream/Parser.hs --- a/Data/JsonStream/Parser.hs +++ b/Data/JsonStream/Parser.hs @@ -19,6 +19,15 @@ -- * How to use this library -- $use + -- * Performance + -- $performance + + -- * Constant space decoding + -- $constant + + -- * Aeson compatibility + -- $aeson + -- * The @Parser@ type Parser , ParseOutput(..) @@ -27,19 +36,35 @@ , runParser' , parseByteString , parseLazyByteString - -- * Basic JSON parsers + -- * FromJSON parser , value + , string + , bytestring + -- * Constant space parsers + , safeString + , number + , integer + , real + , bool + , jNull + -- * Convenience aeson-like operators + , (.:) + , (.:?) + , (.!=) + , (.!) + -- * Structure parsers , objectWithKey , objectItems , objectValues - , array - , arrayWithIndex - , indexedArray + , arrayOf + , arrayWithIndexOf + , indexedArrayOf + , nullable -- * Parsing modifiers + , defaultValue , filterI + , takeI , toList - , defaultValue - , catchFail ) where import Control.Applicative @@ -47,25 +72,34 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import qualified Data.HashMap.Strict as HMap +import Data.Maybe (fromMaybe) +import Data.Scientific (Scientific, isInteger, + toBoundedInteger, toRealFloat) import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text.Lazy as TL +import Data.Text.Lazy.Encoding (decodeUtf8') import qualified Data.Vector as Vec import Data.JsonStream.TokenParser + +-- | Limit for the size of an object key +objectKeyStringLimit :: Int +objectKeyStringLimit = 65536 + -- | Private parsing result data ParseResult v = MoreData (Parser v, BS.ByteString -> TokenResult) | Failed String - | Done TokenResult + | Done (Maybe Element) TokenResult -- ^ The element is ] or }, it is propagated down to proper arr/obj | Yield v (ParseResult v) - | UnexpectedEnd Element TokenResult -- Thrown on ArrayEnd and ObjectEnd instance Functor ParseResult where fmap f (MoreData (np, ntok)) = MoreData (fmap f np, ntok) fmap _ (Failed err) = Failed err - fmap _ (Done tok) = Done tok + fmap _ (Done el tok) = Done el tok fmap f (Yield v np) = Yield (f v) (fmap f np) - fmap _ (UnexpectedEnd el tok) = UnexpectedEnd el tok -- | A representation of the parser. newtype Parser a = Parser { @@ -79,24 +113,23 @@ pure x = Parser $ \tok -> process (callParse ignoreVal tok) where process (Failed err) = Failed err - process (Done tok) = Yield x (Done tok) - process (UnexpectedEnd el tok) = UnexpectedEnd el tok + process (Done Nothing tok) = Yield x (Done Nothing tok) + process (Done (Just el) tok) = Done (Just el) tok -- This is for the end of array, we have already yielded content of it process (MoreData (np, ntok)) = MoreData (Parser (process . callParse np), ntok) process _ = Failed "Internal error in pure, ignoreVal doesn't yield" -- | Run both parsers in parallel using a shared token parser, combine results (<*>) m1 m2 = Parser $ \tok -> process ([], []) (callParse m1 tok) (callParse m2 tok) where + process ([], _) (Done el ntok) _ = Done el ntok -- Optimize, return immediately when first parser fails process (lst1, lst2) (Yield v np1) p2 = process (v:lst1, lst2) np1 p2 process (lst1, lst2) p1 (Yield v np2) = process (lst1, v:lst2) p1 np2 - process _ (Failed err) _ = Failed err - process _ _ (Failed err) = Failed err - process (lst1, lst2) (Done ntok) (Done _) = - yieldResults [ mx my | mx <- lst1, my <- lst2 ] (Done ntok) - process (lst1, lst2) (UnexpectedEnd el ntok) (UnexpectedEnd _ _) = - yieldResults [ mx my | mx <- lst1, my <- lst2 ] (UnexpectedEnd el ntok) + process (lst1, lst2) (Done el ntok) (Done _ _) = + yieldResults [ mx my | mx <- lst1, my <- lst2 ] (Done el ntok) process lsts (MoreData (np1, ntok1)) (MoreData (np2, _)) = MoreData (Parser (\tok -> process lsts (callParse np1 tok) (callParse np2 tok)), ntok1) + process _ (Failed err) _ = Failed err + process _ _ (Failed err) = Failed err process _ _ _ = Failed "Unexpected error in parallel processing <*>." yieldResults values end = foldr Yield end values @@ -107,14 +140,13 @@ -- | Run both parsers in parallel using a shared token parser, yielding from both as the data comes (<|>) m1 m2 = Parser $ \tok -> process (callParse m1 tok) (callParse m2 tok) where - process (Done ntok) (Done _) = Done ntok - process (Failed err) _ = Failed err - process _ (Failed err) = Failed err process (Yield v np1) p2 = Yield v (process np1 p2) process p1 (Yield v np2) = Yield v (process p1 np2) + process (Done el ntok) (Done _ _) = Done el ntok process (MoreData (np1, ntok)) (MoreData (np2, _)) = MoreData (Parser $ \tok -> process (callParse np1 tok) (callParse np2 tok), ntok) - process (UnexpectedEnd el ntok) (UnexpectedEnd _ _) = UnexpectedEnd el ntok + process (Failed err) _ = Failed err + process _ (Failed err) = Failed err process _ _ = error "Unexpected error in parallel processing <|>" array' :: (Int -> Parser a) -> Parser a @@ -122,70 +154,99 @@ case tp of (PartialResult ArrayBegin ntp _) -> arrcontent 0 (callParse (valparse 0) ntp) (PartialResult el ntp _) - | el == ArrayEnd || el == ObjectEnd -> UnexpectedEnd el ntp - | otherwise -> Failed ("Array - unexpected token: " ++ show el) + | el == ArrayEnd || el == ObjectEnd -> Done (Just el) ntp + | otherwise -> callParse ignoreVal tp -- Run ignoreval parser on the same output we got (TokMoreData ntok _) -> MoreData (array' valparse, ntok) (TokFailed _) -> Failed "Array - token failed" where - arrcontent i (Done ntp) = arrcontent (i+1) (callParse (valparse (i + 1)) ntp) -- Reset to next value + arrcontent i (Done Nothing ntp) = arrcontent (i+1) (callParse (valparse (i + 1)) ntp) -- Reset to next value arrcontent i (MoreData (Parser np, ntp)) = MoreData (Parser (arrcontent i . np), ntp) arrcontent i (Yield v np) = Yield v (arrcontent i np) arrcontent _ (Failed err) = Failed err - arrcontent _ (UnexpectedEnd ArrayEnd ntp) = Done ntp - arrcontent _ (UnexpectedEnd el _) = Failed ("Array - UnexpectedEnd: " ++ show el) + arrcontent _ (Done (Just ArrayEnd) ntp) = Done Nothing ntp + arrcontent _ (Done (Just el) _) = Failed ("Array - UnexpectedEnd: " ++ show el) -- | Match all items of an array. -array :: Parser a -> Parser a -array valparse = array' (const valparse) +arrayOf :: Parser a -> Parser a +arrayOf valparse = array' (const valparse) --- | Match n'th item of an array. -arrayWithIndex :: Int -> Parser a -> Parser a -arrayWithIndex idx valparse = array' itemFn +-- | Match nith item in an array. +arrayWithIndexOf :: Int -> Parser a -> Parser a +arrayWithIndexOf idx valparse = array' itemFn where itemFn aidx | aidx == idx = valparse | otherwise = ignoreVal -- | Match all items of an array, add index to output. -indexedArray :: Parser a -> Parser (Int, a) -indexedArray valparse = array' (\(!key) -> (key,) <$> valparse) +indexedArrayOf :: Parser a -> Parser (Int, a) +indexedArrayOf valparse = array' (\(!key) -> (key,) <$> valparse) -object' :: (T.Text -> Parser a) -> Parser a -object' valparse = Parser $ \tp -> - case tp of - (PartialResult ObjectBegin ntp _) -> objcontent (keyValue ntp) - (PartialResult el ntp _) - | el == ArrayEnd || el == ObjectEnd -> UnexpectedEnd el ntp - | otherwise -> Failed ("Object - unexpected token: " ++ show el) - (TokMoreData ntok _) -> MoreData (object' valparse, ntok) - (TokFailed _) -> Failed "Object - token failed" + +-- | Go through an object; if once is True, yield only first success, then ignore the rest +object' :: Bool -> (T.Text -> Parser a) -> Parser a +object' once valparse = Parser $ moreData object'' where - objcontent (Done ntp) = objcontent (keyValue ntp) -- Reset to next value - objcontent (MoreData (Parser np, ntok)) = MoreData (Parser (objcontent . np), ntok) - objcontent (Yield v np) = Yield v (objcontent np) - objcontent (Failed err) = Failed err - objcontent (UnexpectedEnd ObjectEnd ntp) = Done ntp - objcontent (UnexpectedEnd el _) = Failed ("Object - UnexpectedEnd: " ++ show el) + object'' tok el ntok = + case el of + ObjectBegin -> objcontent False (moreData keyValue ntok) + ArrayEnd -> Done (Just el) ntok + ObjectEnd -> Done (Just el) ntok + _ -> callParse ignoreVal tok - keyValue (TokFailed _) = Failed "KeyValue - token failed" - keyValue (TokMoreData ntok _) = MoreData (Parser keyValue, ntok) - keyValue (PartialResult (ObjectKey key) ntok _) = callParse (valparse key) ntok - keyValue (PartialResult el ntok _) - | el == ArrayEnd || el == ObjectEnd = UnexpectedEnd el ntok - | otherwise = Failed ("Array - unexpected token: " ++ show el) + -- If we already yielded and should yield once, ignore the rest of the object + objcontent yielded (Done Nothing ntp) + | once && yielded = callParse (ignoreVal' 1) ntp + | otherwise = objcontent yielded (moreData keyValue ntp) -- Reset to next value + objcontent yielded (MoreData (Parser np, ntok)) = MoreData (Parser (objcontent yielded. np), ntok) + objcontent _ (Yield v np) = Yield v (objcontent True np) + objcontent _ (Failed err) = Failed err + objcontent _ (Done (Just ObjectEnd) ntp) = Done Nothing ntp + objcontent _ (Done (Just el) _) = Failed ("Object - UnexpectedEnd: " ++ show el) + keyValue _ el ntok = + case el of + JValue (AE.String key) -> callParse (valparse key) ntok + StringBegin str -> moreData (getLongKey [str] (BS.length str)) ntok + _| el == ArrayEnd || el == ObjectEnd -> Done (Just el) ntok + | otherwise -> Failed ("Object - unexpected token: " ++ show el) + getLongKey acc len _ el ntok = + case el of + StringEnd + | Right key <- decodeUtf8' (BL.fromChunks $ reverse acc) -> + callParse (valparse $ T.concat $ TL.toChunks key) ntok + | otherwise -> Failed "Error decoding UTF8" + StringContent str + | len > objectKeyStringLimit -> callParse (ignoreStrRestThen ignoreVal) ntok + | otherwise -> moreData (getLongKey (str:acc) (len + BS.length str)) ntok + _ -> Failed "Object longstr - unexpected token." + +-- | Helper function to deduplicate TokMoreData/FokFailed logic +moreData :: (TokenResult -> Element -> TokenResult -> ParseResult v) -> TokenResult -> ParseResult v +moreData parser tok = + case tok of + PartialResult el ntok _ -> parser tok el ntok + TokMoreData ntok _ -> MoreData (Parser (moreData parser), ntok) + TokFailed _ -> Failed "Object longstr - unexpected token." + -- | Match all key-value pairs of an object, return them as a tuple. +-- If the source object defines same key multiple times, all values +-- are matched. objectItems :: Parser a -> Parser (T.Text, a) -objectItems valparse = object' $ \(!key) -> (key,) <$> valparse +objectItems valparse = object' False $ \(!key) -> (key,) <$> valparse -- | Match all key-value pairs of an object, return only values. +-- If the source object defines same key multiple times, all values +-- are matched. Keys are ignored. objectValues :: Parser a -> Parser a -objectValues valparse = object' (const valparse) +objectValues valparse = object' False (const valparse) -- | Match only specific key of an object. +-- This function will return only the first matched value in an object even +-- if the source JSON defines the key multiple times (in violation of the specification). objectWithKey :: T.Text -> Parser a -> Parser a -objectWithKey name valparse = object' itemFn +objectWithKey name valparse = object' True itemFn where itemFn key | key == name = valparse @@ -193,71 +254,188 @@ -- | Parses underlying values and generates a AE.Value aeValue :: Parser AE.Value -aeValue = Parser value' +aeValue = Parser $ moreData value' where - value' (TokFailed _) = Failed "Value - token failed" - value' (TokMoreData ntok _) = MoreData (Parser value', ntok) - value' (PartialResult (JValue val) ntok _) = Yield val (Done ntok) - value' tok@(PartialResult ArrayBegin _ _) = - AE.Array . Vec.fromList <$> callParse (toList (array value)) tok - value' tok@(PartialResult ObjectBegin _ _) = - AE.Object . HMap.fromList <$> callParse (toList (objectItems value)) tok - value' (PartialResult el ntok _) - | el == ArrayEnd || el == ObjectEnd = UnexpectedEnd el ntok - | otherwise = Failed ("aeValue - unexpected token: " ++ show el) + value' tok el ntok = + case el of + JValue val -> Yield val (Done Nothing ntok) + StringBegin _ -> callParse (AE.String <$> longString Nothing) tok + ArrayBegin -> AE.Array . Vec.fromList <$> callParse (toList (arrayOf aeValue)) tok + ObjectBegin -> AE.Object . HMap.fromList <$> callParse (toList (objectItems aeValue)) tok + ArrayEnd -> Done (Just el) ntok + ObjectEnd -> Done (Just el) ntok + _ -> Failed ("aeValue - unexpected token: " ++ show el) +-- | Convert a strict aeson value (no object/array) to a value. +-- Non-matching type is ignored and not parsed (unlike 'value') +jvalue :: (AE.Value -> Maybe a) -> Parser a +jvalue convert = Parser (moreData value') + where + value' tok el ntok = + case el of + JValue val + | Just convValue <- convert val -> Yield convValue (Done Nothing ntok) + | otherwise -> Done Nothing ntok + ArrayEnd -> Done (Just el) ntok + ObjectEnd -> Done (Just el) ntok + _ -> callParse ignoreVal tok + + +-- | Match a possibly bounded string roughly limited by a limit +longString :: Maybe Int -> Parser T.Text +longString mbounds = Parser $ moreData (handle [] 0) + where + handle acc len tok el ntok = + case el of + JValue (AE.String str) -> Yield str (Done Nothing ntok) + StringBegin str -> moreData (handle [str] (BS.length str)) ntok + StringContent str + | (Just bounds) <- mbounds, len > bounds -- If the string exceeds bounds, discard it + -> callParse (ignoreVal' 1) ntok + | otherwise -> moreData (handle (str:acc) (len + BS.length str)) ntok + StringEnd + | Right val <- decodeUtf8' (BL.fromChunks $ reverse acc) + -> Yield (T.concat $ TL.toChunks val) (Done Nothing ntok) + | otherwise -> Failed "Error decoding UTF8" + _ -> callParse ignoreVal tok + +-- | Match string as a ByteString without decoding the data from UTF8 (strings larger than input chunk, +-- small get always decoded). +bytestring :: Parser BL.ByteString +bytestring = Parser $ moreData (handle []) + where + handle acc tok el ntok = + case el of + JValue (AE.String str) -> Yield (BL.fromChunks [encodeUtf8 str]) (Done Nothing ntok) + StringBegin str -> moreData (handle [str]) ntok + StringContent str -> moreData (handle (str:acc)) ntok + StringEnd -> Yield (BL.fromChunks $ reverse acc) (Done Nothing ntok) + _ -> callParse ignoreVal tok + + +-- | Parse string value, skip parsing otherwise. +string :: Parser T.Text +string = longString Nothing + +-- | Stops parsing string after the limit is reached. The string will not be matched +-- if it exceeds the size. +safeString :: Int -> Parser T.Text +safeString limit = longString (Just limit) + +-- | Parse number, return in scientific format. +number :: Parser Scientific +number = jvalue cvt + where + cvt (AE.Number num) = Just num + cvt _ = Nothing + +-- | Parse to integer type. +integer :: (Integral i, Bounded i) => Parser i +integer = jvalue cvt + where + cvt (AE.Number num) + | isInteger num = toBoundedInteger num + cvt _ = Nothing + +-- | Parse to float/double. +real :: RealFloat a => Parser a +real = jvalue cvt + where + cvt (AE.Number num) = Just $ toRealFloat num + cvt _ = Nothing + +-- | Parse bool, skip if the type is not bool. +bool :: Parser Bool +bool = jvalue cvt + where + cvt (AE.Bool b) = Just b + cvt _ = Nothing + +-- | Match a null value. +jNull :: Parser () +jNull = jvalue cvt + where + cvt (AE.Null) = Just () + cvt _ = Nothing + +-- | Parses a field with a possible null value. Use 'defaultValue' for missing values. +nullable :: Parser a -> Parser (Maybe a) +nullable valparse = Parser (moreData value') + where + value' _ (JValue AE.Null) ntok = Yield Nothing (Done Nothing ntok) + value' tok _ _ = callParse (Just <$> valparse) tok + -- | Match 'FromJSON' value. value :: AE.FromJSON a => Parser a value = Parser $ \ntok -> loop (callParse aeValue ntok) where - loop (Done ntp) = Done ntp + loop (Done el ntp) = Done el ntp loop (Failed err) = Failed err - loop (UnexpectedEnd el b) = UnexpectedEnd el b loop (MoreData (Parser np, ntok)) = MoreData (Parser (loop . np), ntok) loop (Yield v np) = case AE.fromJSON v of - AE.Error err -> Failed err + AE.Error _ -> loop np AE.Success res -> Yield res (loop np) --- | Skip value; cheat to avoid parsing and make it faster -ignoreVal :: Parser a -ignoreVal = Parser $ handleTok 0 +-- | Take maximum n matching items. +takeI :: Int -> Parser a -> Parser a +takeI num valparse = Parser $ \tok -> loop num (callParse valparse tok) where - handleTok :: Int -> TokenResult -> ParseResult a - handleTok _ (TokFailed _) = Failed "Token error" - handleTok level (TokMoreData ntok _) = MoreData (Parser (handleTok level), ntok) + loop _ (Done el ntp) = Done el ntp + loop _ (Failed err) = Failed err + loop n (MoreData (Parser np, ntok)) = MoreData (Parser (loop n . np), ntok) + loop 0 (Yield _ np) = loop 0 np + loop n (Yield v np) = Yield v (loop (n-1) np) - handleTok 0 (PartialResult (JValue _) ntok _) = Done ntok - handleTok 0 (PartialResult (ObjectKey _) ntok _) = Done ntok - handleTok 0 (PartialResult elm ntok _) - | elm == ArrayEnd || elm == ObjectEnd = UnexpectedEnd elm ntok - handleTok level (PartialResult (JValue _) ntok _) = handleTok level ntok - handleTok level (PartialResult (ObjectKey _) ntok _) = handleTok level ntok +-- | Skip rest of string + call next parser +ignoreStrRestThen :: Parser a -> Parser a +ignoreStrRestThen next = Parser $ moreData handle + where + handle _ el ntok = + case el of + StringContent _ -> moreData handle ntok + StringEnd -> callParse next ntok + _ -> Failed "Unexpected result in ignoreStrRestPlusOne" - handleTok 1 (PartialResult elm ntok _) - | elm == ArrayEnd || elm == ObjectEnd = Done ntok - handleTok level (PartialResult elm ntok _) - | elm == ArrayBegin || elm == ObjectBegin = handleTok (level + 1) ntok - | elm == ArrayEnd || elm == ObjectEnd = handleTok (level - 1) ntok - handleTok _ _ = Failed "UnexpectedEnd " --- | Fetch yields of a function and return them as list. +-- | Skip value; cheat to avoid parsing and make it faster +ignoreVal :: Parser a +ignoreVal = ignoreVal' 0 + +ignoreVal' :: Int -> Parser a +ignoreVal' stval = Parser $ moreData (handleTok stval) + where + handleTok :: Int -> TokenResult -> Element -> TokenResult -> ParseResult a + handleTok 0 _ (JValue _) ntok = Done Nothing ntok + handleTok 0 _ elm ntok + | elm == ArrayEnd || elm == ObjectEnd = Done (Just elm) ntok + handleTok 1 _ elm ntok + | elm == ArrayEnd || elm == ObjectEnd || elm == StringEnd = Done Nothing ntok + handleTok level _ el ntok = + case el of + JValue _ -> moreData (handleTok level) ntok + StringBegin _ -> moreData (handleTok (level + 1)) ntok + StringEnd -> moreData (handleTok (level - 1)) ntok + StringContent _ -> moreData (handleTok level) ntok + _| el == ArrayBegin || el == ObjectBegin -> moreData (handleTok (level + 1)) ntok + | el == ArrayEnd || el == ObjectEnd -> moreData (handleTok (level - 1)) ntok + | otherwise -> Failed "UnexpectedEnd " + +-- | Gather matches and return them as list. toList :: Parser a -> Parser [a] toList f = Parser $ \ntok -> loop [] (callParse f ntok) where - loop acc (Done ntp) = Yield (reverse acc) (Done ntp) + loop acc (Done el ntp) = Yield (reverse acc) (Done el ntp) loop acc (MoreData (Parser np, ntok)) = MoreData (Parser (loop acc . np), ntok) loop acc (Yield v np) = loop (v:acc) np loop _ (Failed err) = Failed err - loop _ (UnexpectedEnd el _) = Failed ("getYields - UnexpectedEnd: " ++ show el) -- | Let only items matching a condition pass filterI :: (a -> Bool) -> Parser a -> Parser a filterI cond valparse = Parser $ \ntok -> loop (callParse valparse ntok) where - loop (Done ntp) = Done ntp + loop (Done el ntp) = Done el ntp loop (Failed err) = Failed err - loop (UnexpectedEnd el b) = UnexpectedEnd el b loop (MoreData (Parser np, ntok)) = MoreData (Parser (loop . np), ntok) loop (Yield v np) | cond v = Yield v (loop np) @@ -267,29 +445,41 @@ defaultValue :: a -> Parser a -> Parser a defaultValue defvalue valparse = Parser $ \ntok -> loop False (callParse valparse ntok) where - loop True (Done ntp) = Done ntp - loop False (Done ntp) = Yield defvalue (Done ntp) + loop False (Done Nothing ntp) = Yield defvalue (Done Nothing ntp) + loop _ (Done el ntp) = Done el ntp loop _ (Failed err) = Failed err - loop _ (UnexpectedEnd el b) = UnexpectedEnd el b loop found (MoreData (Parser np, ntok)) = MoreData (Parser (loop found . np), ntok) loop _ (Yield v np) = Yield v (loop True np) --- | Catch an error in underlying parser. -catchFail :: Parser a -> Parser a -catchFail valparse = Parser $ \tok -> process (callParse valparse tok) (callParse ignoreVal tok) - where -- Call ignoreVal in parallel, switch to it if the first parser fails - process (Yield v np1) p2 = Yield v (process np1 p2) - process _ (Failed err) = Failed err - process (Done ntok) _ = Done ntok - process _ (Done ntok) = Done ntok - process (UnexpectedEnd el ntok) _ = UnexpectedEnd el ntok - process _ (UnexpectedEnd el ntok) = UnexpectedEnd el ntok - process (MoreData (np1, ntok1)) (MoreData (np2, _)) = - MoreData (Parser (\tok -> process (callParse np1 tok) (callParse np2 tok)), ntok1) - process p1@(Failed _) (MoreData (np2, ntok2)) = - MoreData (Parser (process p1 . callParse np2), ntok2) - process _ _ = Failed "Unexpected error in parallel processing catchFail." +--- Convenience operators +-- | Synonym for 'objectWithKey'. Matches key in an object. +(.:) :: T.Text -> Parser a -> Parser a +(.:) = objectWithKey +infixr 7 .: + +-- | Returns 'Nothing' if value is null or does not exist or match. Otherwise returns 'Just' value. +-- +-- > key .:? val = defaultValue Nothing (key .: nullable val) +(.:?) :: T.Text -> Parser a -> Parser (Maybe a) +key .:? val = defaultValue Nothing (key .: nullable val) +infixr 7 .:? + +-- | Converts 'Maybe' parser into normal one by providing default value instead of 'Nothing'. +-- +-- > nullval .!= defval = fromMaybe defval <$> nullval +(.!=) :: Parser (Maybe a) -> a -> Parser a +nullval .!= defval = fromMaybe defval <$> nullval +infixl 6 .!= + + +-- | Synonym for 'arrayWithIndexOf'. Matches n-th item in array. +(.!) :: Int -> Parser a -> Parser a +(.!) = arrayWithIndexOf +infixr 7 .! + +--- + -- | Result of parsing. Contains continuations to continue parsing. data ParseOutput a = ParseYield a (ParseOutput a) -- ^ Returns a value from a parser. | ParseNeedData (BS.ByteString -> ParseOutput a) -- ^ Parser needs more data to continue parsing. @@ -302,11 +492,11 @@ where parse (MoreData (np, ntok)) = ParseNeedData (parse . callParse np .ntok) parse (Failed err) = ParseFailed err - parse (UnexpectedEnd el _) = ParseFailed $ "UnexpectedEnd item: " ++ show el parse (Yield v np) = ParseYield v (parse np) - parse (Done (PartialResult _ _ rest)) = ParseDone rest - parse (Done (TokFailed rest)) = ParseDone rest - parse (Done (TokMoreData _ rest)) = ParseDone rest + parse (Done Nothing (PartialResult _ _ rest)) = ParseDone rest + parse (Done Nothing (TokFailed rest)) = ParseDone rest + parse (Done Nothing (TokMoreData _ rest)) = ParseDone rest + parse (Done (Just el) _) = ParseFailed $ "UnexpectedEnd item: " ++ show el -- | Run streaming parser, immediately returns 'ParseNeedData'. runParser :: Parser a -> ParseOutput a @@ -341,22 +531,83 @@ -- identical to the aeson decode function; the parsing process can generate more -- objects, therefore the results is [a]. -- --- json-stream style parsing would rather look like this: +-- Example of json-stream style parsing: -- --- > >>> parseByteString (array value) "[1,2,3]" :: [Int] +-- > >>> parseByteString (arrayOf integer) "[1,2,3]" :: [Int] -- > [1,2,3] -- --- Parsers can be combinated using '<*>' and '<|>' operators. These operators cause --- parallel parsing and yield some combination of the parsed values. +-- Parsers can be combinated using '<*>' and '<|>' operators. The parsers are +-- run in parallel and return combinations of the parsed values. -- -- > JSON: text = [{"name": "John", "age": 20}, {"age": 30, "name": "Frank"} ] --- > >>> let parser = array $ (,) <$> objectWithKey "name" value --- > <*> objectWithKey "age" value +-- > >>> let parser = arrayOf $ (,) <$> "name" .: string +-- > <*> "age" .: integer -- > >>> parseByteString parser text :: [(Text,Int)] -- > [("John",20),("Frank",30)] -- --- When parsing larger values, it is advisable to use lazy ByteStrings as the chunking --- of the ByteStrings causes the parsing to continue more efficently because less state --- is needed to be held in memory with parallel parsers. +-- When parsing larger values, it is advisable to use lazy ByteStrings. The parsing +-- is then more memory efficient as less lexical state +-- is needed to be held in memory for parallel parsers. -- -- More examples are available on . + + +-- $constant +-- Constant space decoding is possible if the grammar does not specify non-constant +-- operations. The non-constant operations are 'value', 'string', 'toList' and in some instances +-- '<*>'. +-- +-- 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', +-- 'real' and 'bool' +-- must be used; these parsers reject and do not parse data if it does not match the +-- type. +-- +-- The object key length is limited to ~64K. Object records with longer key are ignored and unparsed. +-- +-- The 'toList' parser works by accumulating all matched values. Obviously, number +-- of such values influences the amount of used memory. +-- +-- The '<*>' operator runs both parsers in parallel and when they are both done, it +-- produces combinations of the received values. It is constant-space as long as the +-- number of element produced by child parsers is limited by a constant. This can be achieved by using +-- '.!' and '.:' functions combined with constant space +-- parsers or limiting the number of returned elements with 'takeI'. +-- +-- 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. + +-- $aeson +-- The parser uses internally "Data.Aeson" types, so that the FromJSON instances are +-- directly usable with the 'value' parser. It may be more convenient to parse the +-- outer structure with json-stream and the inner objects with aeson as long as constant-space +-- decoding is not required. +-- +-- Json-stream defines the object-access operators '.:', '.:?' and '.!=', +-- but in a slightly different albeit more natural way. +-- +-- > -- JSON: [{"name": "test1", "value": 1}, {"name": "test2", "value": null}, {"name": "test3"}] +-- > >>> let person = (,) <$> "name" .: string +-- > >>> <*> "value" .:? integer .!= (-1) +-- > >>> let people = arrayOf person +-- > >>> parseByteString people (..JSON..) +-- > [("test1",1),("test2",-1),("test3",-1)] + +-- $performance +-- The parser tries to do the least amount of work to get the job done. The speed is limited mostly +-- by the lexer (which is not very good). The parser itself is quite efficient in eliminating +-- the work that does not need to be done. +-- +-- This can become quite significant if the resulting structure contains only a subset of the data. +-- The parser skips pieces that are not relevant. Using parsers 'string', 'integer' etc. is preferable +-- to the FromJSON 'value'. +-- +-- It is possible to use the '*>' operator to filter objects based on a condition, e.g.: +-- +-- > arrayOf $ id <$> "error" .: number +-- > *> "name" .: string +-- +-- This will return all objects that contain attribute error with number content. The parser will +-- skip trying to decode the name attribute if error is not found. diff --git a/Data/JsonStream/TokenParser.hs b/Data/JsonStream/TokenParser.hs --- a/Data/JsonStream/TokenParser.hs +++ b/Data/JsonStream/TokenParser.hs @@ -19,7 +19,8 @@ import Data.Text.Encoding (decodeUtf8', encodeUtf8) data Element = ArrayBegin | ArrayEnd | ObjectBegin | ObjectEnd - | ObjectKey T.Text | JValue AE.Value + | StringBegin BS.ByteString | StringContent BS.ByteString | StringEnd + | JValue AE.Value deriving (Show, Eq) -- Internal Interface for parsing monad @@ -55,6 +56,7 @@ instance Monad TokenParser where return x = TokenParser $ \s -> (Intermediate' x, s) + {-# INLINE return #-} m >>= mpost = TokenParser $ \s -> let (res, newstate) = runTokParser m s in case res of @@ -62,6 +64,7 @@ PartialResult' el tokp context -> (PartialResult' el (tokp >>= mpost) context, newstate) TokFailed' context -> (TokFailed' context, newstate) Intermediate' result -> runTokParser (mpost result) newstate + {-# INLINE (>>=) #-} instance Functor TokenResult' where fmap f (TokMoreData' newp ctx) = TokMoreData' (fmap f . newp) ctx @@ -141,7 +144,7 @@ loop acc = do (dta, complete) <- getWhile' predicate if complete - then return $ BS.concat $ reverse (dta:acc) + then return $! BS.concat $ reverse (dta:acc) else loop (dta:acc) -- | Parse unquoted identifier - true/false/null @@ -160,7 +163,7 @@ parseUnicode :: TokenParser Char parseUnicode = do lst <- replicateM 4 pickChar - return $ toEnum $ foldl1 (\a b -> 16 * a + b) $ map hexCharToInt lst + return $! toEnum $ foldl1 (\a b -> 16 * a + b) $ map hexCharToInt lst where hexCharToInt :: Char -> Int hexCharToInt c @@ -169,16 +172,6 @@ | isDigit c = fromEnum c - fromEnum '0' | otherwise = error "Incorrect hex input, internal error." --- --- Choose if this is object key based on next character -{-# INLINE chooseKeyOrValue #-} -chooseKeyOrValue :: T.Text -> TokenParser () -chooseKeyOrValue text = do - chr <- peekChar - if | chr == ':' -> pickChar >> yield (ObjectKey text) - | isSpace chr -> getWhile' isSpace >> chooseKeyOrValue text - | otherwise -> yield $ JValue $ AE.String text - -- | Parse string, when finished check if we are object in dict (followed by :) or just a string parseString :: TokenParser () parseString = do @@ -187,25 +180,29 @@ chr <- peekChar if chr == '"' then pickChar >> handleDecode firstpart - else handleString [firstpart] + else do + yield $ StringBegin firstpart + handleString where handleDecode str = case decodeUtf8' str of Left _ -> failTok - Right val -> chooseKeyOrValue val - handleString acc = do + Right val -> yield $ JValue $ AE.String val + handleString = do chr <- peekChar case chr of '"' -> do _ <- pickChar - handleDecode (BS.concat $ reverse acc) + yield StringEnd '\\' -> do _ <- pickChar specchr <- pickChar nchr <- parseSpecChar specchr - handleString (encodeUtf8 (T.singleton nchr):acc) + yield $ StringContent $ encodeUtf8 (T.singleton nchr) + handleString _ -> do - dstr <- getWhile (\c -> c /= '"' && c /= '\\' ) - handleString (dstr:acc) + (dstr, _) <- getWhile' (\c -> c /= '"' && c /= '\\' ) + yield $ StringContent dstr + handleString parseSpecChar '"' = return '"' parseSpecChar '\\' = return '\\' @@ -222,44 +219,43 @@ parseNumber = do tnumber <- getWhile (\c -> isDigit c || c == '.' || c == '+' || c == '-' || c == 'e' || c == 'E') let - ([(texp, _), (frac, frdigits), (num, numdigits), (csign, _)], rest) = - foldl parseStep ([], tnumber) [parseSign, parseDecimal, parseFract, parseE] + (csign, r1) = parseSign tnumber :: (Int, BS.ByteString) + ((num, numdigits), r2) = parseDecimal r1 :: ((Integer, Int), BS.ByteString) + ((frac, frdigits), r3) = parseFract r2 :: ((Int, Int), BS.ByteString) + (texp, rest) = parseE r3 + when (numdigits == 0 || not (BS.null rest)) failTok - let dpart = fromIntegral csign * (fromIntegral num * (10 ^ frdigits) + fromIntegral frac) :: Integer + let dpart = fromIntegral csign * (num * (10 ^ frdigits) + fromIntegral frac) :: Integer e = texp - frdigits yield $ JValue $ AE.Number $ scientific dpart e where - parseStep :: ([(Int, Int)], BS.ByteString) -> (BS.ByteString -> ((Int, Int), BS.ByteString)) -> ([(Int, Int)], BS.ByteString) - parseStep (lst, txt) f = - let (newi, rest) = f txt - in (newi:lst, rest) - parseFract txt | BS.null txt = ((0, 0), txt) | BS.head txt == '.' = parseDecimal (BS.tail txt) | otherwise = ((0,0), txt) parseE txt - | BS.null txt = ((0, 0), txt) + | BS.null txt = (0, txt) | firstc == 'e' || firstc == 'E' = - let ((sign, d1), rest) = parseSign (BS.tail txt) - ((dnum, d2), trest) = parseDecimal rest - in ((dnum * sign, d1 + d2), trest) - | otherwise = ((0,0), txt) + let (sign, rest) = parseSign (BS.tail txt) + ((dnum, _), trest) = parseDecimal rest :: ((Int, Int), BS.ByteString) + in (dnum * sign, trest) + | otherwise = (0, txt) where firstc = BS.head txt parseSign txt - | BS.null txt = ((1, 0), txt) - | BS.head txt == '+' = ((1, 1), BS.tail txt) - | BS.head txt == '-' = ((-1, 1), BS.tail txt) - | otherwise = ((1, 0), txt) + | BS.null txt = (1, txt) + | BS.head txt == '+' = (1, BS.tail txt) + | BS.head txt == '-' = (-1, BS.tail txt) + | otherwise = (1, txt) parseDecimal txt | BS.null txt = ((0, 0), txt) | otherwise = parseNum txt (0,0) + -- parseNum :: BS.ByteString -> (Integer, Int) -> ((Integer, Int), BS.ByteString) parseNum txt (!start, !digits) | BS.null txt = ((start, digits), txt) | dchr >= 48 && dchr <= 57 = parseNum (BS.tail txt) (start * 10 + fromIntegral (dchr - 48), digits + 1) @@ -280,7 +276,7 @@ | chr == ']' = (PartialResult' ArrayEnd contparse ctx, st) | chr == '{' = (PartialResult' ObjectBegin contparse ctx, st) | chr == '}' = (PartialResult' ObjectEnd contparse ctx, st) - | chr == ',' || isSpace chr = handle (State (BS.dropWhile (\c -> c == ',' || isSpace c) ctx) ctx) + | isBlankChar chr = handle (State (BS.dropWhile isBlankChar dta) ctx) | chr == '"' = runTokParser (parseString >> peekCharInMain) (State rest ctx) | otherwise = (Intermediate' (BS.head dta), st) where @@ -288,6 +284,7 @@ rest = BS.tail dta -- Use data as new context contparse = TokenParser $ const $ handle (State rest rest) + isBlankChar c = c == ',' || c == ':' || isSpace c {-# INLINE mainParser #-} mainParser :: TokenParser () 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.1.0.0 +version: 0.2.0.0 synopsis: Incremental applicative JSON parser description: Easy to use JSON parser fully supporting incremental parsing. Parsing grammar in applicative form. @@ -8,8 +8,8 @@ aeson and its FromJSON class. It is possible to use aeson monadic parsing when appropriate. - The parser supports incremental parsing while using as little - memory as possible with performance comparable to aeson. + The parser supports constant-space incremental parsing + with performance comparable to aeson. homepage: https://github.com/ondrap/json-stream license: BSD3 @@ -33,7 +33,6 @@ , aeson , vector , unordered-containers - , hspec , scientific default-language: Haskell2010 @@ -49,3 +48,4 @@ , vector , unordered-containers , hspec + , scientific