json-stream 0.2.0.0 → 0.3.0.0
raw patch · 6 files changed
+828/−419 lines, 6 filesdep ~base
Dependency ranges changed: base
Files
- Data/JsonStream/CLexType.hsc +30/−0
- Data/JsonStream/CLexer.hs +235/−0
- Data/JsonStream/Parser.hs +196/−122
- Data/JsonStream/TokenParser.hs +9/−290
- c_lib/lexer.c +328/−0
- json-stream.cabal +30/−7
+ Data/JsonStream/CLexType.hsc view
@@ -0,0 +1,30 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Data.JsonStream.CLexType where++import Foreign.C.Types+import Foreign++newtype LexResultType = LexResultType CInt deriving (Show, Eq, Storable)++#include "lexer.h"++resultLimit :: Int+resultLimit = #const RESULT_COUNT++#{enum LexResultType, LexResultType+ , resNumber = RES_NUMBER+ , resString = RES_STRING+ , resTrue = RES_TRUE+ , resFalse = RES_FALSE+ , resNull = RES_NULL++ , resOpenBrace = RES_OPEN_BRACE+ , resCloseBrace = RES_CLOSE_BRACE+ , resOpenBracket = RES_OPEN_BRACKET+ , resCloseBracket = RES_CLOSE_BRACKET++ , resStringPartial = RES_STRING_PARTIAL+ , resStringUni = RES_STRING_UNI+ , resNumberPartial = RES_NUMBER_PARTIAL+ , resNumberSmall = RES_NUMBER_SMALL+ }
+ Data/JsonStream/CLexer.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Data.JsonStream.CLexer (+ tokenParser+) where++import Control.Applicative ((<$>))+import Control.Monad (when)+import qualified Data.Aeson as AE+import qualified Data.ByteString as BSW+import qualified Data.ByteString.Char8 as BS+import Data.ByteString.Unsafe (unsafeUseAsCString)+import Data.Scientific (Scientific, scientific)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8', encodeUtf8)+import Data.Text.Internal.Unsafe (inlinePerformIO)+import Foreign+import Foreign.C.Types+import System.IO.Unsafe (unsafeDupablePerformIO)++import Data.JsonStream.CLexType+import Data.JsonStream.TokenParser (Element (..), TokenResult (..))++-- | Limit for maximum size of a number; fail if larger number is found+-- this is needed to make this constant-space, otherwise we would eat+-- all memory just memoizing the number. The lexer fails if larger number+-- is encountered.+numberDigitLimit :: Int+numberDigitLimit = 200000++newtype ResultPtr = ResultPtr { unresPtr :: ForeignPtr () }++-- | Header for the C routing for batch parsing+data Header = Header {+ hdrCurrentState :: !CInt+ , hdrStateData :: !CInt+ , hdrStateSata2 :: !CInt++ , hdrPosition :: !CInt+ , hdrLength :: !CInt+ , hdrResultNum :: !CInt+} deriving (Show)++instance Storable Header where+ sizeOf _ = 7 * sizeOf (undefined :: CInt)+ alignment _ = sizeOf (undefined :: CInt)+ peek ptr = do+ state <- peekByteOff ptr 0+ sdata1 <- peekByteOff ptr (sizeOf state)+ sdata2 <- peekByteOff ptr (2 * sizeOf state)+ position <- peekByteOff ptr (3 * sizeOf state)+ slength <- peekByteOff ptr (4 * sizeOf state)+ sresultnum <- peekByteOff ptr (5 * sizeOf state)+ return $ Header state sdata1 sdata2 position slength sresultnum+ -- return $ Header state sdata1 sdata2 position slength sresultnum++ poke ptr (Header {..}) = do+ pokeByteOff ptr 0 hdrCurrentState+ pokeByteOff ptr (1 * sizeOf hdrCurrentState) hdrStateData+ pokeByteOff ptr (2 * sizeOf hdrCurrentState) hdrStateSata2+ pokeByteOff ptr (3 * sizeOf hdrCurrentState) hdrPosition+ pokeByteOff ptr (4 * sizeOf hdrCurrentState) hdrLength+ pokeByteOff ptr (5 * sizeOf hdrCurrentState) hdrResultNum++peekResultField :: Int -> Int -> ResultPtr -> Int+peekResultField n fieldno fptr = inlinePerformIO $ -- !! Using inlinePerformIO should be safe - we are just reading bytes from memory+ withForeignPtr (unresPtr fptr) $ \ptr ->+ fromIntegral <$> (peekByteOff ptr (recsize * n + fieldno * isize) :: IO CInt)+ where+ isize = sizeOf (undefined :: CInt)+ recsize = isize * 4++peekResultType :: Int -> ResultPtr -> LexResultType+peekResultType n fptr = inlinePerformIO $ -- !! Using inlinePerformIO should be safe - we are just reading bytes from memory+ withForeignPtr (unresPtr fptr) $ \ptr ->+ LexResultType <$> peekByteOff ptr (recsize * n)+ where+ isize = sizeOf (undefined :: CInt)+ recsize = isize * 4++foreign import ccall unsafe "lex_json" lexJson :: Ptr CChar -> Ptr Header -> Ptr () -> IO CInt++-- Call the C lexer. Returns (Error code, Header, (result_count, result_count, ResultPointer))+callLex :: BS.ByteString -> Header -> (CInt, Header, Int, ResultPtr)+callLex bs hdr = unsafeDupablePerformIO $ -- Using Dupable PerformIO should be safe - at the worst is is executed twice+ alloca $ \hdrptr -> do+ poke hdrptr (hdr{hdrResultNum=0, hdrLength=fromIntegral $ BS.length bs})++ bsptr <- unsafeUseAsCString bs return+ resptr <- mallocForeignPtrBytes (resultLimit * sizeOf (undefined :: CInt) * 4)+ res <- withForeignPtr resptr $ \resptr' ->+ lexJson bsptr hdrptr resptr'++ hdrres <- peek hdrptr+ let !rescount = fromIntegral (hdrResultNum hdrres)+ return (res, hdrres, rescount, ResultPtr resptr)++{-# INLINE substr #-}+substr :: Int -> Int -> BS.ByteString -> BS.ByteString+substr start len = BS.take len . BS.drop start++data TempData = TempData {+ tmpBuffer :: BS.ByteString+ , tmpHeader :: Header+ , tmpError :: Bool+ , tmpNumbers :: [BS.ByteString]+}++-- | Parse number from bytestring to Scientific using JSON syntax rules+parseNumber :: BS.ByteString -> Maybe Scientific+parseNumber tnumber = do+ let+ (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)) Nothing+ let dpart = fromIntegral csign * (num * (10 ^ frdigits) + fromIntegral frac) :: Integer+ e = texp - frdigits+ return $ scientific dpart e+ where+ 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, txt)+ | firstc == 'e' || firstc == 'E' =+ 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, 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 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++-- | Parse particular result+parseResults :: TempData -> (CInt, Header, Int, ResultPtr) -> TokenResult+parseResults (TempData {tmpNumbers=tmpNumbers, tmpBuffer=bs}) (err, hdr, rescount, resptr) = parse 0+ where+ newtemp = TempData bs hdr (err /= 0)+ -- We iterate the items from CNT to 1, 1 is the last element, CNT is the first+ parse n+ | n >= rescount = getNextResult (newtemp tmpNumbers)+ | otherwise =+ let resType = peekResultType n resptr+ resStartPos = peekResultField n 1 resptr+ resLength = peekResultField n 2 resptr+ resAddData = peekResultField n 3 resptr+ next = parse (n + 1)+ context = BS.drop (resStartPos + resLength) bs+ textSection = substr resStartPos resLength bs+ in case () of+ _| resType == resNumberPartial ->+ if | resAddData == 0 -> getNextResult (newtemp [textSection]) -- First part of number+ | sum (map BS.length tmpNumbers) > numberDigitLimit -> TokFailed -- Number too long+ | otherwise -> getNextResult (newtemp (textSection:tmpNumbers)) -- Middle part of number+ | resType == resTrue -> PartialResult (JValue (AE.Bool True)) next+ | resType == resFalse -> PartialResult (JValue (AE.Bool False)) next+ | resType == resNull -> PartialResult (JValue AE.Null) next+ | resType == resOpenBrace -> PartialResult ObjectBegin next+ | resType == resOpenBracket -> PartialResult ArrayBegin next+ -- ObjectEnd and ArrayEnd need pointer to data that wasn't parsed+ | resType == resCloseBrace -> PartialResult (ObjectEnd context) next+ | resType == resCloseBracket -> PartialResult (ArrayEnd context) next+ -- Number optimized - integer+ | resType == resNumberSmall ->+ if | resLength == 0 -> PartialResult (JInteger resAddData) next+ | otherwise -> PartialResult+ (JValue (AE.Number $ scientific (fromIntegral resAddData) ((-1) * resLength)))+ next+ -- Number optimized - floating+ | resType == resNumber ->+ if | resAddData == 0 -> -- Single one-part number+ case parseNumber textSection of+ Just num -> PartialResult (JValue (AE.Number num)) next+ Nothing -> TokFailed+ | otherwise -> -- Concatenate number from partial parts+ case parseNumber (BS.concat $ reverse (textSection:tmpNumbers)) of+ Just num -> PartialResult (JValue (AE.Number num)) next+ Nothing -> TokFailed+ | resType == resString ->+ if | resAddData == 0 -> -- One-part string+ case decodeUtf8' textSection of+ Right ctext -> PartialResult (JValue (AE.String ctext)) next+ Left _ -> TokFailed+ | otherwise -> PartialResult (StringContent textSection) -- Final part of partial strings+ (PartialResult StringEnd next)+ -- -- Unicode+ | resType == resStringUni ->+ PartialResult (StringContent (encodeUtf8 $ T.singleton $ toEnum resAddData)) next+ -- -- Partial string, not the end+ | resType == resStringPartial ->+ if resLength == 0+ then PartialResult (StringContent (BSW.singleton $ fromIntegral resAddData)) next -- \n\r..+ else PartialResult (StringContent textSection) next -- normal string section+ | otherwise -> error "Unsupported"++getNextResult :: TempData -> TokenResult+getNextResult tmp@(TempData {..})+ | tmpError = TokFailed+ | hdrPosition tmpHeader < hdrLength tmpHeader = parseResults tmp (callLex tmpBuffer tmpHeader)+ | otherwise = TokMoreData newdata+ where+ newdata dta = parseResults newtmp (callLex dta newhdr)+ where+ newtmp = tmp{tmpBuffer=dta}+ newhdr = tmpHeader{hdrPosition=0, hdrLength=fromIntegral $ BS.length dta}+++tokenParser :: BS.ByteString -> TokenResult+tokenParser dta = getNextResult (TempData dta newhdr False [])+ where+ newhdr = Header 0 0 0 0 (fromIntegral $ BS.length dta) 0
Data/JsonStream/Parser.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-} -- | -- Module : Data.JsonStream.Parser@@ -31,6 +32,8 @@ -- * The @Parser@ type Parser , ParseOutput(..)+ -- * Operators+ , (>^>) -- * Parsing functions , runParser , runParser'@@ -47,10 +50,10 @@ , real , bool , jNull- -- * Convenience aeson-like operators+ -- * Structure operators , (.:) , (.:?)- , (.!=)+ , (.|) , (.!) -- * Structure parsers , objectWithKey@@ -61,7 +64,6 @@ , indexedArrayOf , nullable -- * Parsing modifiers- , defaultValue , filterI , takeI , toList@@ -72,7 +74,6 @@ 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@@ -81,6 +82,8 @@ import Data.Text.Lazy.Encoding (decodeUtf8') import qualified Data.Vector as Vec +import Data.Bits (clearBit, setBit)+import Data.JsonStream.CLexer (tokenParser) import Data.JsonStream.TokenParser @@ -91,14 +94,15 @@ -- | Private parsing result data ParseResult v = MoreData (Parser v, BS.ByteString -> TokenResult) | Failed String- | Done (Maybe Element) TokenResult -- ^ The element is ] or }, it is propagated down to proper arr/obj+ | 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 el tok) = Done el tok+ fmap _ (Done ctx tok) = Done ctx tok fmap f (Yield v np) = Yield (f v) (fmap f np) -- | A representation of the parser.@@ -109,62 +113,111 @@ 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:+--+-- > JSON: text = [{"name": "John", "age": 20}, {"age": 30, "name": "Frank"} ]+-- > >>> let parser = arrayOf $ (,) <$> "name" .: string+-- > <*> "age" .: integer+-- > >>> parseByteString parser text :: [(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 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 (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" - -- | 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 ([], _) (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 el ntok) (Done _ _) =- yieldResults [ mx my | mx <- lst1, my <- lst2 ] (Done el ntok)+ 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 <*>." - yieldResults values end = foldr Yield end values -+-- | '<|>' will run both parsers in parallel yielding from both as the data comes+--+-- > 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,5,6] 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 (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 (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 _ _ = error "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]++(>^>) :: Parser a -> Parser a -> Parser a+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 _ _ _ = error "Unexpected error in parallel processing >^>"++infixl 3 >^>+ 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 -> 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"+ (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- arrcontent i (Done Nothing ntp) = arrcontent (i+1) (callParse (valparse (i + 1)) ntp) -- Reset to next value+ 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- arrcontent _ (Done (Just ArrayEnd) ntp) = Done Nothing ntp- arrcontent _ (Done (Just el) _) = Failed ("Array - UnexpectedEnd: " ++ show el) -- | Match all items of an array. arrayOf :: Parser a -> Parser a@@ -185,32 +238,27 @@ -- | 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''+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- 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+ nextitem _ _ (ObjectEnd ctx) ntok = Done ctx ntok+ nextitem yielded _ (JValue (AE.String key)) ntok = objcontent yielded (callParse (valparse key) ntok)+ nextitem yielded _ (StringContent str) ntok =+ objcontent yielded $ moreData (getLongKey [str] (BS.length str)) ntok+ nextitem _ _ _ _ = Failed "Object - unexpected item" -- If we already yielded and should yield once, ignore the rest of the object- objcontent yielded (Done Nothing ntp)+ objcontent yielded (Done _ ntp) | once && yielded = callParse (ignoreVal' 1) ntp- | otherwise = objcontent yielded (moreData keyValue ntp) -- Reset to next value+ | 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- 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@@ -220,15 +268,15 @@ StringContent str | len > objectKeyStringLimit -> callParse (ignoreStrRestThen ignoreVal) ntok | otherwise -> moreData (getLongKey (str:acc) (len + BS.length str)) ntok- _ -> Failed "Object longstr - unexpected token."+ _ -> 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 "Object longstr - unexpected token."+ 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@@ -258,26 +306,26 @@ where value' tok el ntok = case el of- JValue val -> Yield val (Done Nothing ntok)- StringBegin _ -> callParse (AE.String <$> longString Nothing) tok+ JValue val -> Yield val (Done "" ntok)+ JInteger val -> Yield (AE.Number $ fromIntegral val) (Done "" ntok)+ StringContent _ -> 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')+jvalue :: (AE.Value -> Maybe a) -> (Int -> 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 Nothing ntok)- | otherwise -> Done Nothing ntok- ArrayEnd -> Done (Just el) ntok- ObjectEnd -> Done (Just el) ntok+ | 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 @@ -287,15 +335,14 @@ 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+ JValue (AE.String str) -> Yield str (Done "" 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)+ -> Yield (T.concat $ TL.toChunks val) (Done "" ntok) | otherwise -> Failed "Error decoding UTF8" _ -> callParse ignoreVal tok @@ -306,10 +353,9 @@ 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+ JValue (AE.String str) -> Yield (BL.fromChunks [encodeUtf8 str]) (Done "" ntok) StringContent str -> moreData (handle (str:acc)) ntok- StringEnd -> Yield (BL.fromChunks $ reverse acc) (Done Nothing ntok)+ StringEnd -> Yield (BL.fromChunks $ reverse acc) (Done "" ntok) _ -> callParse ignoreVal tok @@ -324,14 +370,16 @@ -- | Parse number, return in scientific format. number :: Parser Scientific-number = jvalue cvt+number = jvalue cvt (Just . fromIntegral) where cvt (AE.Number num) = Just num cvt _ = Nothing --- | Parse to integer type.+-- | 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 :: (Integral i, Bounded i) => Parser i-integer = jvalue cvt+integer = jvalue cvt (Just . fromIntegral) where cvt (AE.Number num) | isInteger num = toBoundedInteger num@@ -339,37 +387,41 @@ -- | Parse to float/double. real :: RealFloat a => Parser a-real = jvalue cvt+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+bool = jvalue cvt (const Nothing) where cvt (AE.Bool b) = Just b cvt _ = Nothing -- | Match a null value. jNull :: Parser ()-jNull = jvalue cvt+jNull = jvalue cvt (const Nothing) where cvt (AE.Null) = Just () cvt _ = Nothing --- | Parses a field with a possible null value. Use 'defaultValue' for missing values.+-- | 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 Nothing ntok)+ value' _ (JValue AE.Null) ntok = Yield Nothing (Done "" ntok) value' tok _ _ = callParse (Just <$> valparse) tok --- | Match 'FromJSON' value.+-- | Match 'FromJSON' value. Calls parseJSON on the parsed value.+--+-- > >>> let json = "[{\"key1\": [1,2], \"key2\": [5,6]}]"+-- > >>> parseByteString (arrayOf value) json :: [Value]+-- > [Object fromList [("key2",Array (fromList [Number 5.0,Number 6.0])),("key1",Array (fromList [Number 1.0,Number 2.0]))]] value :: AE.FromJSON a => Parser a value = Parser $ \ntok -> loop (callParse aeValue ntok) where- loop (Done el ntp) = Done el ntp+ 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) =@@ -378,10 +430,13 @@ AE.Success res -> Yield res (loop np) -- | 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 el ntp) = Done el ntp+ 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@@ -406,74 +461,87 @@ 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 0 _ (JValue _) 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- 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 "+ JInteger _ -> moreData (handleTok level) ntok+ StringContent _ -> moreData (handleTok (setBit level 30)) ntok+ StringEnd -> moreData (handleTok (clearBit level 30)) ntok -- The 30s bit indicates that we are in string+ ArrayEnd _ -> moreData (handleTok (level - 1)) ntok+ ObjectEnd _ -> moreData (handleTok (level - 1)) ntok+ ArrayBegin -> moreData (handleTok (level + 1)) ntok+ ObjectBegin -> moreData (handleTok (level + 1)) ntok -- | Gather matches and return them as list.+--+-- > >>> let json = "[{\"keys\":[1,2], \"values\":[5,6]}, {\"keys\":[9,8], \"values\":[7,6]}]"+-- > >>> let parser = arrayOf $ (,) <$> toList ("keys" .: arrayOf integer)+-- > <*> toList ("values" .: arrayOf integer)+-- > >>> parseByteString parser json :: [([Int], [Int])]+-- > [([1,2],[5,6]),([9,8],[7,6])] toList :: Parser a -> Parser [a] toList f = Parser $ \ntok -> loop [] (callParse f ntok) where- loop acc (Done el ntp) = Yield (reverse acc) (Done el ntp)+ loop acc (Done ctx ntp) = Yield (reverse 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 --- | Let only items matching a condition pass+-- | 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 el ntp) = Done el ntp+ 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 --- | 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 False (Done Nothing ntp) = Yield defvalue (Done Nothing ntp)- loop _ (Done el ntp) = Done el ntp- loop _ (Failed err) = Failed err- loop found (MoreData (Parser np, ntok)) = MoreData (Parser (loop found . np), ntok)- loop _ (Yield v np) = Yield v (loop True np)- --- Convenience operators --- | Synonym for 'objectWithKey'. Matches key in an object.+-- | 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 = defaultValue Nothing (key .: nullable val)+-- > key .:? val = Just <$> key .: val >^> pure Nothing (.:?) :: T.Text -> Parser a -> Parser (Maybe a)-key .:? val = defaultValue Nothing (key .: nullable val)+key .:? val = Just <$> key .: val >^> pure Nothing infixr 7 .:? --- | Converts 'Maybe' parser into normal one by providing default value instead of 'Nothing'.+-- | Return default value if the parsers on the left hand didn't produce a result. ----- > nullval .!= defval = fromMaybe defval <$> nullval-(.!=) :: Parser (Maybe a) -> a -> Parser a-nullval .!= defval = fromMaybe defval <$> nullval-infixl 6 .!=+-- > 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 .!@@ -493,16 +561,19 @@ parse (MoreData (np, ntok)) = ParseNeedData (parse . callParse np .ntok) parse (Failed err) = ParseFailed err parse (Yield v np) = ParseYield v (parse np)- 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+ 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@@ -566,6 +637,8 @@ -- -- 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 'toList' parser works by accumulating all matched values. Obviously, number -- of such values influences the amount of used memory. --@@ -585,24 +658,24 @@ -- 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-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. -- -- > -- JSON: [{"name": "test1", "value": 1}, {"name": "test2", "value": null}, {"name": "test3"}] -- > >>> let person = (,) <$> "name" .: string--- > >>> <*> "value" .:? integer .!= (-1)+-- > >>> <*> "value" .: integer .| (-1) -- > >>> let people = arrayOf person--- > >>> parseByteString people (..JSON..)+-- > >>> parseByteString people (..JSON..) :: [(Text, Int)] -- > [("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.+-- 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: ----- 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'.+-- Do not use the 'value' parser for the whole object if the object is big. Using json-stream+-- parsers will produce better results with less memory. The 'integer' parser was optimized in such+-- a way that the integer numbers skip the conversion to scientific, which is unavoidable in aeson. -- -- It is possible to use the '*>' operator to filter objects based on a condition, e.g.: --@@ -611,3 +684,4 @@ -- -- 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
@@ -1,308 +1,27 @@-{-# 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- | StringBegin BS.ByteString | StringContent BS.ByteString | StringEnd- | JValue AE.Value+data Element = ArrayBegin | ArrayEnd BS.ByteString | ObjectBegin | ObjectEnd BS.ByteString+ | StringContent BS.ByteString | StringEnd+ | JValue AE.Value | JInteger Int 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+data TokenResult = TokMoreData (BS.ByteString -> TokenResult)+ | PartialResult Element (TokenResult) -- ^ found element, continuation, actual parsing view - so that we can report the unparsed -- data when the parsing finishes.- | TokFailed BS.ByteString+ | TokFailed -- 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)- {-# INLINE return #-}- 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- {-# INLINE (>>=) #-}--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."---- | 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 do- yield $ StringBegin firstpart- handleString- where- handleDecode str = case decodeUtf8' str of- Left _ -> failTok- Right val -> yield $ JValue $ AE.String val- handleString = do- chr <- peekChar- case chr of- '"' -> do- _ <- pickChar- yield StringEnd- '\\' -> do- _ <- pickChar- specchr <- pickChar- nchr <- parseSpecChar specchr- yield $ StringContent $ encodeUtf8 (T.singleton nchr)- handleString- _ -> do- (dstr, _) <- getWhile' (\c -> c /= '"' && c /= '\\' )- yield $ StringContent dstr- handleString-- 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- (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 * (num * (10 ^ frdigits) + fromIntegral frac) :: Integer- e = texp - frdigits- yield $ JValue $ AE.Number $ scientific dpart e- where- 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, txt)- | firstc == 'e' || firstc == 'E' =- 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, 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)- | 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)- | isBlankChar chr = handle (State (BS.dropWhile isBlankChar dta) 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)- isBlankChar c = c == ',' || c == ':' || isSpace c--{-# 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+ show (TokMoreData _) = "TokMoreData"+ show TokFailed = "TokFailed"+ show (PartialResult el _) = "(PartialResult' " ++ show el ++ ")"
+ c_lib/lexer.c view
@@ -0,0 +1,328 @@+#include <stdio.h>+#include <ctype.h>+#include <string.h>+#include <sys/types.h>+#include <sys/uio.h>+#include <unistd.h>+#include <fcntl.h>++#include "lexer.h"++/*+ * Batch lexer for JSON+ *+ * When each handle_* function is called, 2 things hold:+ * - at least 1 character is available in the input buffer+ * - at least 1 result slot is free+ *+ *+)+ */++static inline int isempty(char chr)+{+ return (chr == ':' || chr == ',' || isspace(chr));+}++static inline int isJnumber(char chr)+{+ return ((chr >= '0' && chr <= '9') || chr == '-' || chr == '.' || chr == '+' || chr == 'e' || chr == 'E');+}++// Add simple result to the result list+static inline void add_simple_res(int restype, struct lexer *lexer, int length)+{+ struct lexer_result *res = &lexer->result[lexer->result_num];++ res->restype = restype;+ res->startpos = lexer->position;+ res->length = length;+ lexer->result_num++;+}++static inline int handle_space(const char *input, struct lexer *lexer)+{+ /* Skip space */+ while (lexer->position < lexer->length && isempty(input[lexer->position]))+ lexer->position++;++ if (lexer->position >= lexer->length)+ return LEX_YIELD;++ return LEX_OK;+}++static inline int handle_base(const char *input, struct lexer *lexer)+{+ if (handle_space(input, lexer))+ return LEX_OK;++ char chr = input[lexer->position];+ switch (chr) {+ case '{': add_simple_res(RES_OPEN_BRACE, lexer, 1); lexer->position++;break;+ case '}': add_simple_res(RES_CLOSE_BRACE, lexer, 1); lexer->position++;break;+ case '[': add_simple_res(RES_OPEN_BRACKET, lexer, 1); lexer->position++;break;+ case ']': add_simple_res(RES_CLOSE_BRACKET, lexer, 1); lexer->position++;break;+ case '"': lexer->current_state = STATE_STRING; lexer->state_data = 0; lexer->position++;return LEX_OK;+ case 't': lexer->current_state = STATE_TRUE; lexer->state_data = 1; lexer->position++;return LEX_OK;+ case 'f': lexer->current_state = STATE_FALSE; lexer->state_data = 1; lexer->position++;return LEX_OK;+ case 'n': lexer->current_state = STATE_NULL; lexer->state_data = 1; lexer->position++;return LEX_OK;+ default:+ if (isJnumber(chr)) {+ lexer->current_state = STATE_NUMBER;+ lexer->state_data = 0;+ return LEX_OK;+ } else {+ // Unknown character+ return LEX_ERROR;+ }+ }+ return LEX_OK;+}++static inline int handle_ident(const char *input, struct lexer *lexer, const char *ident, int idtype)+{+ while (lexer->position < lexer->length) {+ char chr = input[lexer->position];+ if (!ident[lexer->state_data]) {+ // Check that the next character is allowed+ if (isempty(chr) || chr == ']' || chr == '}') {+ add_simple_res(idtype, lexer, lexer->state_data);+ lexer->current_state = STATE_BASE;+ return LEX_OK;+ } else {+ // Unexpected next character in handle_ident+ return LEX_ERROR;+ }+ }+ if (ident[lexer->state_data] != chr)+ return LEX_ERROR;+ lexer->state_data++;+ lexer->position++;+ }+ return LEX_OK;+}++/* Read a number; compute the number if the 'int' type can hold it */+int handle_number(const char *input, struct lexer *lexer)+{+ /* Just eat characters that can be numbers and feed them to a table */+ // Copy the character to buffer+ int startposition = lexer->position;++ // Try to compute the number fitting to int - 32-bit=9, 64-bit=18+ int maxdigits = sizeof(int) == 8 ? 18 : 9;+ int computedNumber = 0;+ int digits = 0;+ int gotDot = 0;+ int dotDigits = 0;+ int invalid = 0;+ int sign = 1;++ // Do not try on number continuation+ if (lexer->state_data)+ invalid = 1;++ for (;lexer->position < lexer->length && isJnumber(input[lexer->position]);++lexer->position) {+ char ch = input[lexer->position];+ if (!invalid) {+ if (lexer->position == startposition && ch == '-') {+ sign = -1;+ } else if (isdigit(ch)) {+ digits++;+ computedNumber = computedNumber * 10 + (ch - '0');+ if (gotDot)+ dotDigits++;+ } else if (ch == '.' && gotDot == 0) {+ gotDot = 1;+ } else+ invalid = 1; // We do not support E notation to optimize or some syntax error++ if (digits > maxdigits)+ invalid = 1;+ }+ }++ struct lexer_result *res = &lexer->result[lexer->result_num];+ res->adddata = lexer->state_data;+ if (lexer->position == lexer->length) {+ res->restype = RES_NUMBER_PARTIAL;+ // We can just point directly to the input+ res->startpos = startposition;+ res->length = lexer->position - startposition;+ lexer->state_data = 1;+ } else if (!invalid) {+ /* Optimized number generation, so that we don't have to parse it in haskell */+ res->restype = RES_NUMBER_SMALL;+ res->adddata = sign * computedNumber;+ res->length = dotDigits;++ lexer->current_state = STATE_BASE;+ } else {+ res->restype = RES_NUMBER;+ // We can just point directly to the input+ res->startpos = startposition;+ res->length = lexer->position - startposition;++ lexer->current_state = STATE_BASE;+ }++ lexer->result_num++;+ return LEX_OK;+}++static inline int safechar(char x) {+ return (x != '"' && x != '\\');+}++/* Handle beginning of a string, the '"' is already stripped */+int handle_string(const char *input, struct lexer *lexer)+{+ int startposition = lexer->position;+ for (char ch=input[lexer->position]; lexer->position < lexer->length && safechar(ch); ch = input[++lexer->position])+ ;++ struct lexer_result *res = &lexer->result[lexer->result_num];+ res->startpos = startposition;+ res->length = lexer->position - startposition;+ if (lexer->position == lexer->length || input[lexer->position] == '\\') {+ // Emit partial string+ res->restype = RES_STRING_PARTIAL;+ res->adddata = 0;+ if (res->length != 0) // Do not add new result, if length == 0+ lexer->result_num++;++ // If we stopped because of backslash, change state, move one forward+ if (lexer->position < lexer->length) {+ lexer->current_state = STATE_STRING_SPECCHAR;+ lexer->state_data = 0;+ lexer->position++;+ } else+ lexer->state_data = 1;+ return LEX_OK;+ } else if (input[lexer->position] == '"') {+ res->restype = RES_STRING;+ res->adddata = lexer->state_data;++ lexer->result_num++;+ lexer->current_state = STATE_BASE;+ lexer->position++; // Skip the final '"'+ return LEX_OK;+ }+ // Internal error, shouldn't get here+ return LEX_ERROR;+}++/* Handle \uxxxx syntax */+static int handle_string_uni(const char *input, struct lexer *lexer)+{+ char chr = input[lexer->position];+ lexer->state_data_2 *= 16;+ if (chr >= 'a' && chr <='f')+ lexer->state_data_2 += 10 + (chr - 'a');+ else if (chr >= 'A' && chr <= 'F')+ lexer->state_data_2 += 10 + (chr - 'A');+ else if (chr >= '0' && chr <= '9')+ lexer->state_data_2 += chr - '0';+ else+ return LEX_ERROR;+ lexer->state_data += 1;+ lexer->position += 1;+ if (lexer->state_data == 4) {+ // Emit the result+ struct lexer_result *res = &lexer->result[lexer->result_num];+ res->startpos = lexer->position;+ res->length = 0;+ res->restype = RES_STRING_UNI;+ res->adddata = lexer->state_data_2;+ lexer->result_num++;++ lexer->current_state = STATE_STRING;+ lexer->state_data = 1; // Set that we are in partial string, see handle_string+ }+ return LEX_OK;+}++// Add a character to result, move position forward, change state back to string+static inline void emitchar(char ch, struct lexer *lexer)+{+ struct lexer_result *res = &lexer->result[lexer->result_num];++ res->restype = RES_STRING_PARTIAL;+ res->startpos = lexer->position;+ res->length = 0;+ res->adddata = ch;++ lexer->result_num++;+ lexer->position++;+ lexer->current_state = STATE_STRING;+ lexer->state_data = 1; // Set the string is in partial data+}++int handle_specchar(const char *input, struct lexer *lexer)+{+ char chr = input[lexer->position];+ switch (chr) {+ case '"': emitchar('"', lexer);break;+ case '\\':emitchar('\\', lexer);break;+ case '/':emitchar('/', lexer);break;+ case 'b':emitchar('\b', lexer);break;+ case 'f':emitchar('\f', lexer);break;+ case 'n':emitchar('\n', lexer);break;+ case 'r':emitchar('\r', lexer);break;+ case 't':emitchar('\t', lexer);break;+ case 'u':+ lexer->current_state = STATE_STRING_UNI;+ lexer->state_data = 0;+ lexer->state_data_2 = 0;+ lexer->position++;+ break;+ default:+ return LEX_ERROR;+ }+ return LEX_OK;+}++int lex_json(const char *input, struct lexer *lexer, struct lexer_result *result)+{+ lexer->result = result;+ int res = LEX_OK;+ static void* dispatch_table[] = {+ &&state_base, &&state_string, &&state_number, &&state_true,+ &&state_false, &&state_null, &&state_string_specchar,+ &&state_string_uni+ };+ #define DISPATCH() { \+ if (!(lexer->position < lexer->length && lexer->result_num < RESULT_COUNT && res == 0)) \+ return res; \+ goto *dispatch_table[lexer->current_state];\+ }++ DISPATCH();+ state_base:+ res = handle_base(input, lexer);+ DISPATCH();+ state_string:+ res = handle_string(input, lexer);+ DISPATCH();+ state_number:+ res = handle_number(input, lexer);+ DISPATCH();+ state_true:+ res = handle_ident(input, lexer, "true", RES_TRUE);+ DISPATCH();+ state_false:+ res = handle_ident(input, lexer, "false", RES_FALSE);+ DISPATCH();+ state_null:+ res = handle_ident(input, lexer, "null", RES_NULL);+ DISPATCH();+ state_string_specchar:+ res = handle_specchar(input, lexer);+ DISPATCH();+ state_string_uni:+ res = handle_string_uni(input, lexer);+ DISPATCH();++ return res;+}
json-stream.cabal view
@@ -1,15 +1,16 @@ name: json-stream-version: 0.2.0.0+version: 0.3.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 is compatibile with aeson and its FromJSON class.+ It is possible to use aeson monadic parsing when appropriate. - The parser supports constant-space incremental parsing- with performance comparable to aeson.+ The parser supports constant-space safe incremental parsing regardless+ of the input data. In addition to performance-critical parts written in C,+ a lot of performance is gained by being less memory intensive especially+ when used for stream parsing. homepage: https://github.com/ondrap/json-stream license: BSD3@@ -24,9 +25,12 @@ type: git location: https://github.com/ondrap/json-stream.git + library exposed-modules: Data.JsonStream.Parser- other-modules: Data.JsonStream.TokenParser+ other-modules: Data.JsonStream.TokenParser, Data.JsonStream.CLexType, Data.JsonStream.CLexer+ c-sources: c_lib/lexer.c+ include-dirs: c_lib build-depends: base >=4.7 && <4.8 , bytestring , text@@ -38,6 +42,10 @@ test-suite spec main-is: Spec.hs+ other-modules: Data.JsonStream.CLexType+ c-sources: c_lib/lexer.c+ include-dirs: c_lib+ type: exitcode-stdio-1.0 hs-source-dirs: test, . default-language: Haskell2010@@ -49,3 +57,18 @@ , unordered-containers , hspec , scientific++-- executable spdtest+-- main-is: spdtest.hs+-- other-modules: Data.JsonStream.TokenParser, Data.JsonStream.CLexType, Data.JsonStream.CLexer+-- ghc-options: -O2 -Wall -fprof-auto+-- c-sources: c_lib/lexer.c+-- include-dirs: c_lib+-- default-language: Haskell2010+-- build-depends: base >=4.7 && <4.8+-- , bytestring+-- , text+-- , aeson+-- , vector+-- , unordered-containers+-- , scientific