diff --git a/Data/JsonStream/CLexType.hsc b/Data/JsonStream/CLexType.hsc new file mode 100644 --- /dev/null +++ b/Data/JsonStream/CLexType.hsc @@ -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 + } diff --git a/Data/JsonStream/CLexer.hs b/Data/JsonStream/CLexer.hs new file mode 100644 --- /dev/null +++ b/Data/JsonStream/CLexer.hs @@ -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 diff --git a/Data/JsonStream/Parser.hs b/Data/JsonStream/Parser.hs --- a/Data/JsonStream/Parser.hs +++ b/Data/JsonStream/Parser.hs @@ -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. +-- diff --git a/Data/JsonStream/TokenParser.hs b/Data/JsonStream/TokenParser.hs --- a/Data/JsonStream/TokenParser.hs +++ b/Data/JsonStream/TokenParser.hs @@ -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 ++ ")" diff --git a/c_lib/lexer.c b/c_lib/lexer.c new file mode 100644 --- /dev/null +++ b/c_lib/lexer.c @@ -0,0 +1,328 @@ +#include +#include +#include +#include +#include +#include +#include + +#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; +} diff --git a/json-stream.cabal b/json-stream.cabal --- a/json-stream.cabal +++ b/json-stream.cabal @@ -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