json-stream-0.4.4.1: Data/JsonStream/Parser.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
-- |
-- Module : Data.JsonStream.Parser
-- License : BSD-style
--
-- Maintainer : palkovsky.ondrej@gmail.com
-- Stability : experimental
-- Portability : portable
--
-- 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
-- easily combined with aeson monadic parsing instances when appropriate.
module Data.JsonStream.Parser (
-- * How to use this library
-- $use
-- * Performance
-- $performance
-- * Constant space decoding
-- $constant
-- * Aeson compatibility
-- $aeson
-- * The @Parser@ type
Parser
, ParseOutput(..)
-- * Parsing functions
, runParser
, runParser'
, parseByteString
, parseLazyByteString
-- * Aeson in-place replacement functions
, decode
, eitherDecode
, decodeStrict
, eitherDecodeStrict
-- * FromJSON parser
, value
, valueWith
, string
, byteString
-- * Constant space parsers
, safeString
, number
, integer
, real
, bool
, jNull
, safeByteString
-- * Structure operators
, (.:)
, (.:?)
, (.|)
, (.!)
-- * Structure parsers
, objectWithKey
, objectItems
, objectValues
, objectKeyValues
, arrayOf
, arrayWithIndexOf
, indexedArrayOf
, nullable
-- * Parsing modifiers
, filterI
, takeI
, mapWithFailure
, manyReverse
-- * 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 qualified Data.Aeson as AE
import qualified Data.Aeson.Types as AE
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.ByteString.Lazy.Internal as BL
import Data.Char (isSpace)
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as AEK
import qualified Data.Aeson.Key as AEK
import Data.Bifunctor (first)
#else
import qualified Data.HashMap.Strict as HMap
#endif
import Data.Scientific (Scientific, isInteger,
toBoundedInteger, toRealFloat)
import qualified Data.Text as T
import qualified Data.Vector as Vec
import Foreign.C.Types
import Data.JsonStream.CLexer
import Data.JsonStream.TokenParser
import Data.JsonStream.Unescape (unsafeDecodeASCII)
-- | 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 BS.ByteString TokenResult
-- The bytestring is remaining unparsed data, we need to return it somehow
| Yield v (ParseResult v)
instance Functor ParseResult where
fmap f (MoreData (np, ntok)) = MoreData (fmap f np, ntok)
fmap _ (Failed err) = Failed err
fmap _ (Done ctx tok) = Done ctx tok
fmap f (Yield v np) = Yield (f v) (fmap f np)
-- | A representation of the parser.
newtype Parser a = Parser {
callParse :: TokenResult -> ParseResult a
}
instance Functor Parser where
fmap f (Parser p) = Parser $ \d -> fmap f (p d)
-- | Yield list of results, finish with last action
yieldResults :: [a] -> ParseResult a -> ParseResult a
yieldResults values end = foldr Yield end values
-- | '<*>' will run both parsers in parallel and combine results.
--
-- It behaves as a list functor (produces all combinations), but the typical
-- use is:
--
-- >>> :set -XOverloadedStrings
-- >>> let text = "[{\"name\": \"John\", \"age\": 20}, {\"age\": 30, \"name\": \"Frank\"}]"
-- >>> let parser = arrayOf $ (,) <$> "name" .: string <*> "age" .: integer
-- >>> parseByteString parser text :: [(T.Text,Int)]
-- [("John",20),("Frank",30)]
instance Applicative Parser where
pure x = Parser $ \tok -> process (callParse ignoreVal tok)
where
process (Failed err) = Failed err
process (Done ctx tok) = Yield x (Done ctx tok)
process (MoreData (np, ntok)) = MoreData (Parser (process . callParse np), ntok)
process _ = Failed "Internal error in pure, ignoreVal doesn't yield"
(<*>) m1 m2 = Parser $ \tok -> process ([], []) (callParse m1 tok) (callParse m2 tok)
where
process ([], _) (Done ctx ntok) _ = Done ctx 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 (lst1, lst2) (Done ctx ntok) (Done {}) =
yieldResults [ mx my | mx <- reverse lst1, my <- reverse lst2 ] (Done ctx 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 <*>."
-- | '<>' will run both parsers in parallel yielding from both as the data comes
--
-- >>> :m +Data.Monoid
-- >>> let test = "[{\"key1\": [1,2], \"key2\": [5,6], \"key3\": [8,9]}]"
-- >>> 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)
process p1 (Yield v np2) = Yield v (process p1 np2)
process (Done ctx ntok) Done {} = Done ctx ntok
process (MoreData (np1, ntok)) (MoreData (np2, _)) =
MoreData (Parser $ \tok -> process (callParse np1 tok) (callParse np2 tok), ntok)
process (Failed err) _ = Failed err
process _ (Failed err) = Failed err
process _ _ = Failed "Unexpected error in parallel processing <|>"
-- | Match items from the first parser, if none is matched, return items
-- from the second parser. Constant-space if second parser returns
-- constant number of items. '.|' is implemented using this operator.
--
-- >>> let json = "[{\"key1\": [1,2], \"key2\": [5,6], \"key3\": [8,9]}]"
-- >>> let parser = arrayOf $ "key1" .: (arrayOf value) <|> "key2" .: (arrayOf value)
-- >>> parseByteString parser json :: [Int]
-- [1,2]
-- >>> let parser = arrayOf $ "key-non" .: (arrayOf value) <|> "key2" .: (arrayOf value)
-- >>> parseByteString parser json :: [Int]
-- [5,6]
--
-- 'many' - Gather matches and return them as list.
--
-- >>> let json = "[{\"keys\":[1,2], \"values\":[5,6]}, {\"keys\":[9,8], \"values\":[7,6]}]"
-- >>> let parser = arrayOf $ (,) <$> many ("keys" .: arrayOf integer) <*> many ("values" .: arrayOf integer)
-- >>> parseByteString parser json :: [([Int], [Int])]
-- [([1,2],[5,6]),([9,8],[7,6])]
instance Alternative Parser where
empty = ignoreVal
m1 <|> m2 = Parser $ \tok -> process [] (callParse m1 tok) (Just $ callParse m2 tok)
where
-- First returned item -> disable second parser
process _ (Yield v np1) _ = Yield v (process [] np1 Nothing)
-- First done with disabled second -> exit
process _ (Done ctx ntok) Nothing = Done ctx ntok
-- Both done but second not disabled -> yield items from the second
process lst (Done ctx ntok) (Just (Done {})) = yieldResults (reverse lst) (Done ctx ntok)
-- Second yield - remember data
process lst np1 (Just (Yield v np2)) = process (v:lst) np1 (Just np2)
-- Moredata processing
process lst (MoreData (np1, ntok)) Nothing =
MoreData (Parser $ \tok -> process lst (callParse np1 tok) Nothing, ntok)
process lst (MoreData (np1, ntok)) (Just (MoreData (np2, _))) =
MoreData (Parser $ \tok -> process lst (callParse np1 tok) (Just $ callParse np2 tok), ntok)
process _ (Failed err) _ = Failed err
process _ _ (Just (Failed err)) = Failed err
process _ _ _ = Failed "Unexpected error in parallel processing <|>"
some = filterI (not . null) . many
many f = Parser $ \ntok -> loop id (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 (\nxt -> acc (v : nxt)) np
loop _ (Failed err) = Failed err
array' :: (Int -> Parser a) -> Parser a
array' valparse = Parser $ \tp ->
case tp of
(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"
where
nextitem !_ _ (ArrayEnd ctx) ntok = Done ctx ntok
nextitem !i tok _ _ = arrcontent i (callParse (valparse i) tok)
arrcontent !i (Done _ ntp) = moreData (nextitem (i+1)) ntp
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
-- | Match all items of an array.
arrayOf :: Parser a -> Parser a
arrayOf valparse = array' (const valparse)
-- | Generate start/end objects when an element is found, in between run a parser.
-- The inner parser is not run if an array is not found.
elemFound :: Element -> a -> a -> Parser a -> Parser a
elemFound elsearch start end parser = Parser $ moreData handle
where
handle tok el _
| el == elsearch = Yield start (parseAndAppend (callParse parser tok))
handle tok _ _ = callParse ignoreVal tok
parseAndAppend (Failed err) = Failed err
parseAndAppend (Yield v np) = Yield v (parseAndAppend np)
parseAndAppend (MoreData (Parser np, ntp)) = MoreData (Parser (parseAndAppend . np), ntp)
parseAndAppend (Done ctx ntp) = Yield end (Done ctx ntp)
-- | Generate start/end values when an object is found, in between run a parser.
-- The inner parser is not run if an array is not found.
objectFound :: a -> a -> Parser a -> Parser a
objectFound = elemFound ObjectBegin
-- | Generate start/end values when an array is found, in between run a parser.
-- The inner parser is not run if an array is not found.
--
-- >>> let test = "[[1,2,3],true,[],false,{\"key\":1}]" :: BS.ByteString
-- >>> parseByteString (arrayOf (arrayFound 10 20 (1 .! integer))) test :: [Int]
-- [10,2,20,10,20]
arrayFound :: a -> a -> Parser a -> Parser a
arrayFound = elemFound ArrayBegin
-- | 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.
indexedArrayOf :: Parser a -> Parser (Int, a)
indexedArrayOf valparse = array' (\(!key) -> (key,) <$> valparse)
-- | 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 $ \tp ->
case tp of
(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"
where
nextitem _ _ (ObjectEnd ctx) ntok = Done ctx ntok
nextitem yielded _ (JValue (AE.String key)) ntok =
objcontent yielded (callParse (valparse key) ntok)
nextitem yielded _ (StringRaw bs True) ntok =
objcontent yielded (callParse (valparse (unsafeDecodeASCII bs)) ntok)
nextitem yielded _ (StringRaw bs False) ntok =
case unescapeText bs of
Right t -> objcontent yielded (callParse (valparse t) ntok)
Left e -> Failed (show e)
nextitem yielded _ (StringContent str) ntok =
objcontent yielded $ moreData (getLongKey [str] (BS.length str)) ntok
nextitem _ _ el _ = Failed $ "Object - unexpected item: " ++ show el
-- If we already yielded and should yield once, ignore the rest of the object
objcontent yielded (Done _ ntp)
| once && yielded = callParse (ignoreVal' 1) ntp
| otherwise = moreData (nextitem yielded) 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
getLongKey acc !len _ el ntok =
case el of
StringEnd
| Right key <- unescapeText (BS.concat $ reverse acc) ->
callParse (valparse 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 - lexer failed."
-- | 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 "More data - lexer failed."
-- | 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' 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' False (const valparse)
-- | Match all key-value pairs of an object, and parse the value based on the key.
-- If the source object defines same key multiple times, all values
-- are matched.
objectKeyValues :: (T.Text -> Parser a) -> Parser a
objectKeyValues = object' False
-- | 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' True itemFn
where
itemFn key
| key == name = valparse
| otherwise = ignoreVal
-- | Parses underlying values and generates a AE.Value
aeValue :: Parser AE.Value
aeValue = Parser $ moreData value'
where
#if MIN_VERSION_aeson(2,0,0)
tomap = AEK.fromList . map (first AEK.fromText)
#else
tomap = HMap.fromList
#endif
value' tok el ntok =
case el of
JValue val -> Yield val (Done "" ntok)
JInteger val -> Yield (AE.Number $ fromIntegral val) (Done "" ntok)
StringContent _ -> callParse (AE.String <$> longString Nothing) tok
StringRaw bs True -> Yield (AE.String (unsafeDecodeASCII bs)) (Done "" ntok)
StringRaw bs False -> case unescapeText bs of
Right t -> Yield (AE.String t) (Done "" ntok)
Left e -> Failed (show e)
ArrayBegin -> AE.Array . Vec.fromList <$> callParse (many (arrayOf aeValue)) tok
ObjectBegin -> AE.Object . tomap <$> callParse (manyReverse (objectItems aeValue)) tok
_ -> Failed ("aeValue - unexpected token: " ++ show el)
-- | Identical to @fmap 'reverse' . 'many'@ but more efficient.
-- If you don't care about the order of the results but plan to fully evaluate the list,
-- this can be slightly more efficient than 'many' as it avoids the accumulating thunks.
manyReverse :: Parser a -> Parser [a]
manyReverse f = Parser $ \ntok -> loop [] (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 (v : acc) np
loop _ (Failed err) = Failed err
-- | 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) -> (CLong -> Maybe a) -> Parser a
jvalue convert cvtint = Parser (moreData value')
where
value' tok el ntok =
case el of
JValue val
| Just convValue <- convert val -> Yield convValue (Done "" ntok)
| otherwise -> Done "" ntok
JInteger val
| Just convValue <- cvtint val -> Yield convValue (Done "" ntok)
| otherwise -> Done "" ntok
_ -> callParse ignoreVal tok
longByteString :: Maybe Int -> Parser BS.ByteString
longByteString mbounds = Parser $ moreData (handle id 0)
where
handle acc !len tok el ntok =
case el of
JValue (AE.String _) -> Failed "INTERNAL ERROR! - got decoded JValue instead of string"
StringRaw bs _ -> Yield bs (Done "" ntok)
StringContent str
| (Just bounds) <- mbounds, len > bounds -- If the string exceeds bounds, discard it
-> callParse (ignoreStrRestThen (Parser $ Done "")) ntok
| otherwise -> moreData (handle (acc . (str:)) (len + BS.length str)) ntok
StringEnd -> Yield (BS.concat (acc [])) (Done "" ntok)
_ -> callParse ignoreVal tok
-- | Parse raw bytestring value (json string expected), skip parsing otherwise.
-- The returned value is not unescaped.
byteString :: Parser BS.ByteString
byteString = longByteString Nothing
-- | Stops parsing string after the limit is reached. The string will not be matched
-- if it exceeds the size. The size is the size of escaped string including escape
-- characters.
-- The return value is not unescaped.
safeByteString :: Int -> Parser BS.ByteString
safeByteString limit = longByteString (Just limit)
-- | Match a possibly bounded string roughly limited by a limit
longString :: Maybe Int -> Parser T.Text
longString mbounds = Parser $ moreData (handle id 0)
where
handle acc !len tok el ntok =
case el of
JValue (AE.String str) -> Yield str (Done "" ntok)
StringRaw bs True -> Yield (unsafeDecodeASCII bs) (Done "" ntok)
StringRaw bs False ->
case unescapeText bs of
Right t -> Yield t (Done "" ntok)
Left e -> Failed (show e)
StringContent str
| (Just bounds) <- mbounds, len > bounds -- If the string exceeds bounds, discard it
-> callParse (ignoreStrRestThen (Parser $ Done "")) ntok
| otherwise -> moreData (handle (acc . (str:)) (len + BS.length str)) ntok
StringEnd
| Right val <- unescapeText (BS.concat (acc []))
-> Yield val (Done "" ntok)
| otherwise -> Failed "Error decoding UTF8"
_ -> 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. The size is the size of escaped string including escape
-- characters.
safeString :: Int -> Parser T.Text
safeString limit = longString (Just limit)
-- | Parse number, return in scientific format.
number :: Parser Scientific
number = jvalue cvt (Just . fromIntegral)
where
cvt (AE.Number num) = Just num
cvt _ = Nothing
-- | Parse to bounded integer type (not 'Integer').
-- If you are using integer numbers, use this parser.
-- It skips the conversion JSON -> 'Scientific' -> 'Int' and uses an 'Int' directly.
integer :: forall i. (Integral i, Bounded i) => Parser i
integer = jvalue cvt clongToBounded
where
clmax = toInteger (maxBound :: CLong)
clmin = toInteger (minBound :: CLong)
imax = toInteger (maxBound :: i)
imin = toInteger (minBound :: i)
-- Int is generally CLong, so we get this
clongIsSmaller = clmax <= imax && clmin >= imin
-- If partial, we have to convert to Integer to do the checking
clongIsPartial = clmax < imax || clmin > imin
inBounds num
| clongIsPartial = toInteger num <= imax && toInteger num >= imin
| otherwise = num <= fromIntegral (maxBound :: i) && num >= fromIntegral (minBound :: i)
clongToBounded :: CLong -> Maybe i
clongToBounded num
| clongIsSmaller || inBounds num = Just (fromIntegral num)
| otherwise = Nothing
cvt (AE.Number num)
| isInteger num = toBoundedInteger num
cvt _ = Nothing
-- | Parse to float/double.
real :: RealFloat a => Parser a
real = jvalue cvt (Just . fromIntegral)
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 (const Nothing)
where
cvt (AE.Bool b) = Just b
cvt _ = Nothing
-- | Match a null value.
jNull :: Parser ()
jNull = jvalue cvt (const Nothing)
where
cvt (AE.Null) = Just ()
cvt _ = Nothing
-- | Parses a field with a possible null value.
nullable :: Parser a -> Parser (Maybe a)
nullable valparse = Parser (moreData value')
where
value' _ (JValue AE.Null) ntok = Yield Nothing (Done "" ntok)
value' tok _ _ = callParse (Just <$> valparse) tok
-- | Match values with a 'AE.Parser'. Returns values for which the given parser succeeds.
valueWith :: (AE.Value -> AE.Parser a) -> Parser a
valueWith jparser = Parser $ \ntok -> loop (callParse aeValue 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 np) =
case AE.parse jparser v of
AE.Error _ -> loop np
AE.Success res -> Yield res (loop np)
-- | Match 'AE.FromJSON' value. Equivalent to @'valueWith' 'AE.parseJSON'@.
--
-- >>> let json = "[{\"key1\": [1,2], \"key2\": [5,6]}]"
-- >>> parseByteString (arrayOf value) json :: [AE.Value]
-- [Object (fromList [("key2",Array [Number 5.0,Number 6.0]),("key1",Array [Number 1.0,Number 2.0])])]
value :: AE.FromJSON a => Parser a
value = valueWith AE.parseJSON
-- | Take maximum n matching items.
--
-- >>> parseByteString (takeI 3 $ arrayOf integer) "[1,2,3,4,5,6,7,8,9,0]" :: [Int]
-- [1,2,3]
takeI :: Int -> Parser a -> Parser a
takeI num valparse = Parser $ \tok -> loop num (callParse valparse tok)
where
loop _ (Done ctx ntp) = Done ctx 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)
-- | 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"
-- | 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
handleLongString level _ (StringContent _) ntok = moreData (handleLongString level) ntok
handleLongString 0 _ StringEnd ntok = Done "" ntok
handleLongString level _ StringEnd ntok = moreData (handleTok level) ntok
handleLongString _ _ el _ = Failed $ "Unexpected element in handleLongStr: " ++ show el
handleTok :: Int -> TokenResult -> Element -> TokenResult -> ParseResult a
handleTok 0 _ (JValue _) ntok = Done "" ntok
handleTok 0 _ (StringRaw _ _) ntok = Done "" ntok
handleTok 0 _ (JInteger _) ntok = Done "" ntok
handleTok 0 _ (ArrayEnd _) _ = Failed "ArrayEnd in ignoreval on 0 level"
handleTok 0 _ (ObjectEnd _) _ = Failed "ObjectEnd in ignoreval on 0 level"
handleTok 1 _ (ArrayEnd ctx) ntok = Done ctx ntok
handleTok 1 _ (ObjectEnd ctx) ntok = Done ctx ntok
handleTok level _ el ntok =
case el of
JValue _ -> moreData (handleTok level) ntok
JInteger _ -> moreData (handleTok level) ntok
StringContent _ -> moreData (handleLongString level) ntok
StringRaw _ _ -> moreData (handleTok level) ntok
ArrayEnd _ -> moreData (handleTok (level - 1)) ntok
ObjectEnd _ -> moreData (handleTok (level - 1)) ntok
ArrayBegin -> moreData (handleTok (level + 1)) ntok
ObjectBegin -> moreData (handleTok (level + 1)) ntok
StringEnd -> Failed "Internal error - out of order StringEnd"
-- | Let only items matching a condition pass.
--
-- >>> parseByteString (filterI (>5) $ arrayOf integer) "[1,2,3,4,5,6,7,8,9,0]" :: [Int]
-- [6,7,8,9]
filterI :: (a -> Bool) -> Parser a -> Parser a
filterI cond 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 np)
| cond v = Yield v (loop np)
| otherwise = loop np
-- | A back-door for lifting of possibly failing actions.
-- If an action fails with Left value, convert it into failure
-- of parsing
mapWithFailure :: (a -> Either String b) -> Parser a -> Parser b
mapWithFailure mapping =
updateParser
where
updateParser (Parser run) = Parser $ updateParseResult . run
updateParseResult x = case x of
MoreData (parser, continuation) -> MoreData (updateParser parser, continuation)
Failed message -> Failed message
Done a b -> Done a b
Yield val parseResult -> case mapping val of
Left message -> Failed message
Right val' -> Yield val' (updateParseResult parseResult)
--- 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 .:
-- | 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 .:?
-- | 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
infixl 6 .|
-- | Synonym for 'arrayWithIndexOf'. Matches n-th item in array.
--
-- >>> parseByteString (arrayOf (1 .! bool)) "[ [1,true,null], [2,false], [3]]" :: [Bool]
-- [True,False]
(.!) :: 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.
| ParseFailed String -- ^ Parsing failed, error is reported.
| ParseDone BS.ByteString -- ^ Parsing finished, unparsed data is returned.
-- | Run streaming parser with initial input.
runParser' :: Parser a -> BS.ByteString -> ParseOutput a
runParser' parser startdata = parse $ callParse parser (tokenParser startdata)
where
parse (MoreData (np, ntok)) = ParseNeedData (parse . callParse np .ntok)
parse (Failed err) = ParseFailed err
parse (Yield v np) = ParseYield v (parse np)
parse (Done ctx _) = ParseDone ctx
-- | Run streaming parser, immediately returns 'ParseNeedData'.
runParser :: Parser a -> ParseOutput a
runParser parser = runParser' parser BS.empty
-- | Parse a bytestring, generate lazy list of parsed values. If an error occurs, throws an exception.
--
-- >>> parseByteString (arrayOf integer) "[1,2,3,4]" :: [Int]
-- [1,2,3,4]
--
-- >>> parseByteString (arrayOf ("name" .: string)) "[{\"name\":\"KIWI\"}, {\"name\":\"BIRD\"}]"
-- ["KIWI","BIRD"]
parseByteString :: Parser a -> BS.ByteString -> [a]
parseByteString parser startdata = loop (runParser' parser startdata)
where
loop (ParseNeedData _) = error "Not enough data."
loop (ParseDone _) = []
loop (ParseFailed err) = error err
loop (ParseYield v np) = v : loop np
-- | Parse a lazy bytestring, generate lazy list of parsed values. If an error occurs, throws an exception.
parseLazyByteString :: Parser a -> BL.ByteString -> [a]
parseLazyByteString parser input = loop input (runParser parser)
where
loop BL.Empty (ParseNeedData _) = error "Not enough data."
loop (BL.Chunk dta rest) (ParseNeedData np) = loop rest (np dta)
loop _ (ParseDone _) = []
loop _ (ParseFailed err) = error err
loop rest (ParseYield v np) = v : loop rest np
-- | Deserialize a JSON value from lazy 'BL.ByteString'.
--
-- If this fails due to incomplete or invalid input, 'Nothing' is returned.
--
-- The input must consist solely of a JSON document, with no trailing data except for whitespace.
decode :: AE.FromJSON a => BL.ByteString -> Maybe a
decode bs =
case eitherDecode bs of
Right val -> Just val
Left _ -> Nothing
-- | Like 'decode' but returns an error message when decoding fails.
eitherDecode :: AE.FromJSON a => BL.ByteString -> Either String a
eitherDecode bs = loop bs (runParser value)
where
loop BL.Empty (ParseNeedData _) = Left "Not enough data."
loop (BL.Chunk dta rest) (ParseNeedData np) = loop rest (np dta)
loop _ (ParseDone _) = Left "Nothing parsed."
loop _ (ParseFailed err) = Left err
loop rest (ParseYield v next) = checkExit v next rest
checkExit v (ParseDone srest) rest
| BS.all isSpace srest && BL.all isSpace rest = Right v
| otherwise = Left "Data followed by non-whitespace characters."
checkExit _ (ParseYield _ _) _ = Left "Multiple value parses?"
checkExit _ (ParseFailed err) _ = Left err
checkExit _ (ParseNeedData _) BL.Empty = Left "Incomplete json structure."
checkExit v (ParseNeedData cont) (BL.Chunk dta rest) = checkExit v (cont dta) rest
-- | Like 'decode', but on strict 'BS.ByteString'
decodeStrict :: AE.FromJSON a => BS.ByteString -> Maybe a
decodeStrict bs =
case eitherDecodeStrict bs of
Right val -> Just val
Left _ -> Nothing
-- | Like 'eitherDecode', but on strict 'BS.ByteString'
eitherDecodeStrict :: AE.FromJSON a => BS.ByteString -> Either String a
eitherDecodeStrict bs =
case runParser' value bs of
ParseYield next v -> checkExit v next
ParseNeedData _ -> Left "Incomplete json structure."
ParseFailed err -> Left err
ParseDone _ -> Left "No data found."
where
checkExit (ParseDone rest) v
| BS.all isSpace rest = Right v
checkExit _ _ = Left "Data folowed by non-whitespace characters."
-- $use
--
-- >>> parseByteString value "[1,2,3]" :: [[Int]]
-- [[1,2,3]]
--
-- The 'value' parser matches any 'AE.FromJSON' value. The above command is essentially
-- identical to the aeson decode function; the parsing process can generate more
-- objects, therefore the results is [a].
--
-- Example of json-stream style parsing:
--
-- >>> parseByteString (arrayOf integer) "[1,2,3]" :: [Int]
-- [1,2,3]
--
-- Parsers can be combinated using '<*>' and '<|>' operators. The parsers are
-- run in parallel and return combinations of the parsed values.
--
-- >>> let text = "[{\"name\": \"John\", \"age\": 20}, {\"age\": 30, \"name\": \"Frank\"} ]"
-- >>> let parser = arrayOf $ (,) <$> "name" .: string <*> "age" .: integer
-- >>> parseByteString parser text :: [(T.Text,Int)]
-- [("John",20),("Frank",30)]
--
-- 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', 'many' 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.
--
-- Numbers are limited to 200.000 digits. Longer numbers will make the parsing fail.
--
-- The 'many' 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 '.:', '.:?'
-- but in a slightly different albeit more natural way. New operators are '.!' for
-- array access and '.|' to handle missing values.
--
-- >>> let test = "[{\"name\": \"test1\", \"value\": 1}, {\"name\": \"test2\", \"value\": null}, {\"name\": \"test3\"}]"
-- >>> let person = (,) <$> "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.
--
-- > arrayOf value :: Parser MyStructure -- MyStructure with FromJSON instance
--
-- will probably behave better than
--
-- > arrayOf $ MyStructure <$> "field1" .: string <*> "field2" .: integer <*> .... <*> "field20" .: string
--
-- and also better (at least memory-wise) than
--
-- > value :: Parser [MyStructure]
--
-- unless the structure has hundreths of fields and you are parsing only a substructure.
--
-- The 'integer' parser was optimized in such
-- a way that the integer numbers skip the conversion to 'Scientific', resulting in a slightly
-- faster speed.
--
-- 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.
--