json-stream (empty) → 0.1.0.0
raw patch · 6 files changed
+757/−0 lines, 6 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, hspec, scientific, text, unordered-containers, vector
Files
- Data/JsonStream/Parser.hs +362/−0
- Data/JsonStream/TokenParser.hs +311/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- json-stream.cabal +51/−0
- test/Spec.hs +1/−0
+ Data/JsonStream/Parser.hs view
@@ -0,0 +1,362 @@+{-# LANGUAGE BangPatterns #-}+{-# 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++ -- * The @Parser@ type+ Parser+ , ParseOutput(..)+ -- * Parsing functions+ , runParser+ , runParser'+ , parseByteString+ , parseLazyByteString+ -- * Basic JSON parsers+ , value+ , objectWithKey+ , objectItems+ , objectValues+ , array+ , arrayWithIndex+ , indexedArray+ -- * Parsing modifiers+ , filterI+ , toList+ , defaultValue+ , catchFail+) where++import Control.Applicative+import qualified Data.Aeson as AE+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.HashMap.Strict as HMap+import qualified Data.Text as T+import qualified Data.Vector as Vec++import Data.JsonStream.TokenParser++-- | Private parsing result+data ParseResult v = MoreData (Parser v, BS.ByteString -> TokenResult)+ | Failed String+ | Done TokenResult+ | 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 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 {+ callParse :: TokenResult -> ParseResult a+}++instance Functor Parser where+ fmap f (Parser p) = Parser $ \d -> fmap f (p d)++instance Applicative Parser where+ 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 (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 (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 lsts (MoreData (np1, ntok1)) (MoreData (np2, _)) =+ MoreData (Parser (\tok -> process lsts (callParse np1 tok) (callParse np2 tok)), ntok1)+ process _ _ _ = Failed "Unexpected error in parallel processing <*>."++ yieldResults values end = foldr Yield end values+++instance Alternative Parser where+ empty = ignoreVal+ -- | 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 (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 _ _ = error "Unexpected error in parallel processing <|>"++array' :: (Int -> Parser a) -> Parser a+array' valparse = Parser $ \tp ->+ 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)+ (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 (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)++-- | Match all items of an array.+array :: Parser a -> Parser a+array valparse = array' (const valparse)++-- | Match n'th item of an array.+arrayWithIndex :: Int -> Parser a -> Parser a+arrayWithIndex 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)++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"+ 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)++ 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)+++-- | Match all key-value pairs of an object, return them as a tuple.+objectItems :: Parser a -> Parser (T.Text, a)+objectItems valparse = object' $ \(!key) -> (key,) <$> valparse++-- | Match all key-value pairs of an object, return only values.+objectValues :: Parser a -> Parser a+objectValues valparse = object' (const valparse)++-- | Match only specific key of an object.+objectWithKey :: T.Text -> Parser a -> Parser a+objectWithKey name valparse = object' itemFn+ where+ itemFn key+ | key == name = valparse+ | otherwise = ignoreVal++-- | Parses underlying values and generates a AE.Value+aeValue :: Parser AE.Value+aeValue = Parser 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)++-- | Match 'FromJSON' value.+value :: AE.FromJSON a => Parser a+value = Parser $ \ntok -> loop (callParse aeValue ntok)+ where+ loop (Done ntp) = Done 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.Success res -> Yield res (loop np)++-- | Skip value; cheat to avoid parsing and make it faster+ignoreVal :: Parser a+ignoreVal = Parser $ handleTok 0+ where+ handleTok :: Int -> TokenResult -> ParseResult a+ handleTok _ (TokFailed _) = Failed "Token error"+ handleTok level (TokMoreData ntok _) = MoreData (Parser (handleTok level), ntok)++ 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++ 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.+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 (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 (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)+ | otherwise = loop np++-- | Returns a value if none is found upstream.+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 _ (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."++-- | 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 (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++-- | 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 :: 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 chunks (runParser parser)+ where+ chunks = BL.toChunks input+ loop [] (ParseNeedData _) = error "Not enough data."+ loop (dta:rest) (ParseNeedData np) = loop rest (np dta)+ loop _ (ParseDone _) = []+ loop _ (ParseFailed err) = error err+ loop rest (ParseYield v np) = v : loop rest np+++-- $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].+--+-- json-stream style parsing would rather look like this:+--+-- > >>> parseByteString (array value) "[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.+--+-- > JSON: text = [{"name": "John", "age": 20}, {"age": 30, "name": "Frank"} ]+-- > >>> let parser = array $ (,) <$> objectWithKey "name" value+-- > <*> objectWithKey "age" value+-- > >>> 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.+--+-- More examples are available on <https://github.com/ondrap/json-stream>.
+ Data/JsonStream/TokenParser.hs view
@@ -0,0 +1,311 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.JsonStream.TokenParser (+ Element(..)+ , TokenResult(..)+ , tokenParser+) where++import Control.Applicative+import Control.Monad (replicateM, when, (>=>))+import qualified Data.Aeson as AE+import qualified Data.ByteString as BSW+import qualified Data.ByteString.Char8 as BS+import Data.Char (isDigit, isDigit, isLower, isSpace)+import Data.Scientific (scientific)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8', encodeUtf8)++data Element = ArrayBegin | ArrayEnd | ObjectBegin | ObjectEnd+ | ObjectKey T.Text | JValue AE.Value+ deriving (Show, Eq)++-- Internal Interface for parsing monad+data TokenResult' a = TokMoreData' (BS.ByteString -> TokenParser a) BS.ByteString+ | PartialResult' Element (TokenParser a) BS.ByteString+ -- ^ found element, continuation, actual parsing view - so that we can report the unparsed+ -- data when the parsing finishes.+ | TokFailed' BS.ByteString+ | Intermediate' a+++-- | Public interface for parsing JSON tokens.+data TokenResult = TokMoreData (BS.ByteString -> TokenResult) BS.ByteString+ | PartialResult Element (TokenResult) BS.ByteString+ -- ^ found element, continuation, actual parsing view - so that we can report the unparsed+ -- data when the parsing finishes.+ | TokFailed BS.ByteString++-- For debugging purposes+instance Show TokenResult where+ show (TokMoreData _ ctx) = "(TokMoreData' + " ++ show ctx ++ ")"+ show (TokFailed _) = "TokFailed'"+ show (PartialResult el _ rest) = "(PartialResult' " ++ show el ++ " " ++ show rest ++ ")"++data State = State {+ stData :: BS.ByteString+ , stContext :: BS.ByteString+}++newtype TokenParser a = TokenParser {+ runTokParser :: State -> (TokenResult' a, State)+}++instance Monad TokenParser where+ return x = TokenParser $ \s -> (Intermediate' x, s)+ m >>= mpost = TokenParser $ \s ->+ let (res, newstate) = runTokParser m s+ in case res of+ TokMoreData' cont context -> (TokMoreData' (cont >=> mpost) context, newstate)+ PartialResult' el tokp context -> (PartialResult' el (tokp >>= mpost) context, newstate)+ TokFailed' context -> (TokFailed' context, newstate)+ Intermediate' result -> runTokParser (mpost result) newstate++instance Functor TokenResult' where+ fmap f (TokMoreData' newp ctx) = TokMoreData' (fmap f . newp) ctx+ fmap f (PartialResult' el tok ctx) = PartialResult' el (fmap f tok) ctx+ fmap _ (TokFailed' ctx) = TokFailed' ctx+ fmap f (Intermediate' a) = Intermediate' (f a)++instance Applicative TokenParser where+ pure = return+ f <*> param = do+ mf <- f+ mparam <- param+ return (mf mparam)++instance Functor TokenParser where+ fmap f tokp = TokenParser $ \s ->+ let (res, newstate) = runTokParser tokp s+ in (fmap f res, newstate)++failTok :: TokenParser a+failTok = TokenParser $ \s -> (TokFailed' (stContext s), s)++{-# INLINE isBreakChar #-}+isBreakChar :: Char -> Bool+isBreakChar c = isSpace c || (c == '{') || (c == '[') || (c == '}') || (c == ']') || (c == ',')++{-# INLINE peekChar #-}+peekChar :: TokenParser Char+peekChar = TokenParser handle+ where+ -- handle :: State -> (TokenResult' a, State)+ handle st@(State dta context)+ | BS.null dta = (TokMoreData' (\newdta -> TokenParser $ \_ -> handle (State newdta (BS.append context newdta)))+ context+ , st)+ | otherwise = (Intermediate' (BS.head dta), st)++{-# INLINE pickChar #-}+pickChar :: TokenParser Char+pickChar = TokenParser handle+ where+ handle st@(State dta context)+ | BS.null dta = (TokMoreData' (\newdta -> TokenParser $ \_ -> handle (State newdta (BS.append context newdta)))+ context+ , st)+ | otherwise = (Intermediate' (BS.head dta), State (BS.tail dta) context)++{-# INLINE yield #-}+yield :: Element -> TokenParser ()+yield el = TokenParser $ \state@(State dta ctx) -> (PartialResult' el (contparse dta) ctx, state)+ where+ -- Use data as new context+ contparse dta = TokenParser $ const (Intermediate' (), State dta dta )++-- | Return SOME input satisfying predicate or none, if the next element does not satisfy+-- Return tuple (str satisfying predicate, true_if_next_char_does_not_satisfy)+{-# INLINE getWhile' #-}+getWhile' :: (Char -> Bool) -> TokenParser (BS.ByteString, Bool)+getWhile' predicate = do+ char <- peekChar+ if predicate char then getBuf+ else return ("", True)+ where+ getBuf = TokenParser $ \(State dta ctx) ->+ let (st,rest) = BS.span predicate dta+ in (Intermediate' (st, not (BS.null rest)), State rest ctx)++-- | Read ALL input satisfying predicate+{-# INLINE getWhile #-}+getWhile :: (Char -> Bool) -> TokenParser BS.ByteString+getWhile predicate = do+ (dta, complete) <- getWhile' predicate+ if complete+ then return dta+ else loop [dta]+ where+ loop acc = do+ (dta, complete) <- getWhile' predicate+ if complete+ then return $ BS.concat $ reverse (dta:acc)+ else loop (dta:acc)++-- | Parse unquoted identifier - true/false/null+parseIdent :: TokenParser ()+parseIdent = do+ ident <- getWhile isLower+ nextchar <- peekChar+ if | isBreakChar nextchar -> toTemp ident -- We found a barrier -> parse+ | otherwise -> failTok+ where+ toTemp "true" = yield $ JValue $ AE.Bool True+ toTemp "false" = yield $ JValue $ AE.Bool False+ toTemp "null" = yield $ JValue AE.Null+ toTemp _ = failTok++parseUnicode :: TokenParser Char+parseUnicode = do+ lst <- replicateM 4 pickChar+ return $ toEnum $ foldl1 (\a b -> 16 * a + b) $ map hexCharToInt lst+ where+ hexCharToInt :: Char -> Int+ hexCharToInt c+ | c >= 'A' && c <= 'F' = 10 + (fromEnum c - fromEnum 'A')+ | c >= 'a' && c <= 'f' = 10 + (fromEnum c - fromEnum 'a')+ | 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+ -- leading '"' removed upstream+ (firstpart, _) <- getWhile' (\c -> c /= '"' && c /= '\\' )+ chr <- peekChar+ if chr == '"'+ then pickChar >> handleDecode firstpart+ else handleString [firstpart]+ where+ handleDecode str = case decodeUtf8' str of+ Left _ -> failTok+ Right val -> chooseKeyOrValue val+ handleString acc = do+ chr <- peekChar+ case chr of+ '"' -> do+ _ <- pickChar+ handleDecode (BS.concat $ reverse acc)+ '\\' -> do+ _ <- pickChar+ specchr <- pickChar+ nchr <- parseSpecChar specchr+ handleString (encodeUtf8 (T.singleton nchr):acc)+ _ -> do+ dstr <- getWhile (\c -> c /= '"' && c /= '\\' )+ handleString (dstr:acc)++ parseSpecChar '"' = return '"'+ parseSpecChar '\\' = return '\\'+ parseSpecChar '/' = return '/'+ parseSpecChar 'b' = return '\b'+ parseSpecChar 'f' = return '\f'+ parseSpecChar 'n' = return '\n'+ parseSpecChar 'r' = return '\r'+ parseSpecChar 't' = return '\t'+ parseSpecChar 'u' = parseUnicode+ parseSpecChar c = return c++parseNumber :: TokenParser ()+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]+ when (numdigits == 0 || not (BS.null rest)) failTok++ let dpart = fromIntegral csign * (fromIntegral 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)+ | 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)+ 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)++ parseDecimal txt+ | BS.null txt = ((0, 0), txt)+ | otherwise = parseNum txt (0,0)++ 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)+ | otherwise = ((start, digits), txt)+ where+ dchr = BSW.head txt++{-# INLINE peekCharInMain #-}+-- Specialized version of peek char for main function so that we get faster performance+peekCharInMain :: TokenParser Char+peekCharInMain = TokenParser handle+ where+ handle st@(State dta ctx)+ | BS.null dta = (TokMoreData' (\newdta -> TokenParser $ \_ -> handle (State newdta (BS.append ctx newdta)))+ ctx+ , st)+ | chr == '[' = (PartialResult' ArrayBegin contparse ctx, st)+ | 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)+ | chr == '"' = runTokParser (parseString >> peekCharInMain) (State rest ctx)+ | otherwise = (Intermediate' (BS.head dta), st)+ where+ chr = BS.head dta+ rest = BS.tail dta+ -- Use data as new context+ contparse = TokenParser $ const $ handle (State rest rest)++{-# INLINE mainParser #-}+mainParser :: TokenParser ()+mainParser = do+ chr <- peekCharInMain+ case chr of+ 't' -> parseIdent+ 'f' -> parseIdent+ 'n' -> parseIdent+ '-' -> parseNumber+ _| isDigit chr -> parseNumber+ | otherwise -> failTok++-- | Incremental lexer+tokenParser :: BS.ByteString -> TokenResult+tokenParser dta = handle $ runTokParser mainParser (State dta dta)+ where+ handle (TokMoreData' ntp ctx, st) = TokMoreData (\ndta -> handle $ runTokParser (ntp ndta) st) ctx+ handle (PartialResult' el ntp ctx, st) = PartialResult el (handle $ runTokParser ntp st) ctx+ handle (TokFailed' ctx, _) = TokFailed ctx+ handle (Intermediate' _, st) = handle $ runTokParser mainParser st
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Ondrej Palkovsky++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Ondrej Palkovsky nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ json-stream.cabal view
@@ -0,0 +1,51 @@+name: json-stream+version: 0.1.0.0+synopsis: Incremental applicative JSON parser+description: Easy to use JSON parser fully supporting incremental parsing.+ Parsing grammar in applicative form.++ The parser is compatibile with+ 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.++homepage: https://github.com/ondrap/json-stream+license: BSD3+license-file: LICENSE+author: Ondrej Palkovsky+maintainer: palkovsky.ondrej@gmail.com+category: Text, JSON+build-type: Simple+cabal-version: >=1.10++source-repository head+ type: git+ location: https://github.com/ondrap/json-stream.git++library+ exposed-modules: Data.JsonStream.Parser+ other-modules: Data.JsonStream.TokenParser+ build-depends: base >=4.7 && <4.8+ , bytestring+ , text+ , aeson+ , vector+ , unordered-containers+ , hspec+ , scientific+ default-language: Haskell2010++test-suite spec+ main-is: Spec.hs+ type: exitcode-stdio-1.0+ hs-source-dirs: test, .+ default-language: Haskell2010+ build-depends: base >=4.7 && <4.8+ , bytestring+ , text+ , aeson+ , vector+ , unordered-containers+ , hspec
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}