json-stream 0.1.0.0 → 0.2.0.0
raw patch · 3 files changed
+416/−168 lines, 3 files
Files
- Data/JsonStream/Parser.hs +377/−126
- Data/JsonStream/TokenParser.hs +35/−38
- json-stream.cabal +4/−4
Data/JsonStream/Parser.hs view
@@ -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 <https://github.com/ondrap/json-stream>.+++-- $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.
Data/JsonStream/TokenParser.hs view
@@ -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 ()
json-stream.cabal view
@@ -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