diff --git a/Data/JsonStream/Parser.hs b/Data/JsonStream/Parser.hs new file mode 100644 --- /dev/null +++ b/Data/JsonStream/Parser.hs @@ -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 . diff --git a/Data/JsonStream/TokenParser.hs b/Data/JsonStream/TokenParser.hs new file mode 100644 --- /dev/null +++ b/Data/JsonStream/TokenParser.hs @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/json-stream.cabal b/json-stream.cabal new file mode 100644 --- /dev/null +++ b/json-stream.cabal @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}