WIP.

- Parse strings with escaped quotes properly
- Parse double

Author: pranaysashank

src/Streamly/Internal/Data/Json/Stream.hs

@@ -7,17 +7,16 @@
 -- Stability   : experimental
 -- Portability : GHC
 
-{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
 
-{-# LANGUAGE OverloadedLists #-}
-
-module Streamly.Internal.Data.Json.Stream 
-    ( parseJson )
+module Streamly.Internal.Data.Json.Stream
+    ( parseJson
+    , parseJsonEOF
+    )
 where
 
 import Control.Monad (when)
 import Control.Monad.Catch (MonadCatch)
-import Data.Bits (testBit)
 import Data.Char (chr, ord)
 import Data.Functor.Identity (runIdentity)
 import Data.Word (Word8)
@@ -30,6 +29,7 @@ import qualified Data.Scientific as Sci
 import Streamly.Internal.Data.Parser.ParserD (Parser)
 import Streamly.Internal.Data.Array (Array)
 import Streamly.Internal.Data.Fold.Types (Fold(..))
+import Streamly.Internal.Data.Strict (Tuple' (..))
 import qualified Streamly.Internal.Data.Parser as PR
 import qualified Streamly.Internal.Data.Parser.ParserD as P
 import qualified Streamly.Internal.Data.Array as A
@@ -56,27 +56,12 @@ import qualified Streamly.Data.Fold as FL
 #define C_n 110
 #define C_t 116
 
+backslash, zero, minus, plus :: Word8
 backslash = 92 :: Word8
-close_curly = 125 :: Word8
-close_square = 93 :: Word8
-comma = 44 :: Word8
-double_quote = 34 :: Word8
-open_curly = 123 :: Word8
-open_square = 91 :: Word8
-colon = 58 :: Word8
-c_0 = 48 :: Word8
-c_9 = 57 :: Word8
-c_A = 65 :: Word8
-c_F = 70 :: Word8
-c_a = 97 :: Word8
-c_f = 102 :: Word8
-c_n = 110 :: Word8
-c_t = 116 :: Word8
 zero = 48 :: Word8
 minus = 45 :: Word8
 plus = 43 :: Word8
 
-
 instance Enum a => Hashable (A.Array a) where
     hash arr = fromIntegral $ runIdentity $ IUF.fold A.read IFL.rollingHash arr
     hashWithSalt salt arr = fromIntegral $ runIdentity $
@@ -99,46 +84,33 @@ data Value
     | Null
     deriving (Eq, Show)
 
-{-# INLINE pushToFold #-}
-pushToFold :: Monad m => Fold m a b -> a -> Fold m a b
-pushToFold (Fold step initial extract) a = Fold step initial' extract
-    where
-    initial' = do
-        s <- initial
-        step s a
-
 {-# INLINE skipSpace #-}
 skipSpace :: MonadCatch m => Parser m Word8 ()
 skipSpace =
     P.takeWhile
         (\w -> w == 0x20 || w == 0x0a || w == 0x0d || w == 0x09)
         FL.drain
 
-{-# INLINE spaceAround #-}
-spaceAround :: MonadCatch m => Parser m Word8 b -> Parser m Word8 b
-spaceAround parseInBetween = do
-    skipSpace
-    between <- parseInBetween
-    skipSpace
-    return between
-
 {-# INLINE skip #-}
 skip :: MonadCatch m => Int -> Parser m a ()
 skip n = P.take n FL.drain
 
 {-# INLINE string #-}
+
 string :: MonadCatch m => String -> Parser m Word8 ()
 string = P.eqBy (==) . map (fromIntegral . ord)
 
 {-# INLINE match #-}
 match :: MonadCatch m => Word8 -> Parser m Word8 ()
 match w = P.eqBy (==) [w]
 
+{-# SPECIALISE foldToInteger :: Monad m => Int -> Fold m Word8 Int #-}
+{-# SPECIALISE foldToInteger :: Monad m => Integer -> Fold m Word8 Integer #-}
 {-# INLINE foldToInteger #-}
-foldToInteger :: Monad m => Fold m Word8 Integer
-foldToInteger = Fold step initial extract
+foldToInteger :: (Num a, Monad m) => a -> Fold m Word8 a
+foldToInteger begin = Fold step initial extract
   where
-    initial = return 0
+    initial = return begin
 
     step s a = return $ s * 10 + fromIntegral (a - 48)
 
@@ -147,10 +119,20 @@ foldToInteger = Fold step initial extract
 {-# INLINE parseDecimal0 #-}
 parseDecimal0 :: MonadCatch m => Parser m Word8 Integer
 parseDecimal0 = do
-    h <- P.peek
-    n <- P.peek
-    when (h == zero && n - 48 > 9) $ P.die "Leading zero in a number is not accepted in JSON."
-    P.takeWhile1 (\w -> w - 48 <= 9) foldToInteger
+    z <- P.peek
+    n <- P.takeWhile1 (\w -> w - 48 <= 9) (foldToInteger 0)
+    when (z == zero && n /= 0) $ do
+        P.die $ " Leading zero in a number is not accepted in JSON."
+    return n
+
+{-# INLINE parseDecimal #-}
+parseDecimal :: MonadCatch m => Parser m Word8 Int
+parseDecimal = do
+  sign <- P.peek
+  let positive = sign == plus || sign /= minus
+      pr = P.takeWhile1 (\w -> w - 48 <= 9) (foldToInteger 0)
+  when (sign == plus || sign == minus) (skip 1)
+  if positive then pr else negate <$> pr
 
 {-# INLINE parseJsonNumber #-}
 parseJsonNumber :: MonadCatch m => Parser m Word8 Scientific
@@ -159,8 +141,24 @@ parseJsonNumber = do
     let positive = sign == plus || sign /= minus
     when (sign == plus || sign == minus) (skip 1)
     n <- parseDecimal0
-    let signedCoeff = if positive then n else (-n)
-    return (Sci.scientific signedCoeff 0)
+    dot <- P.peekMaybe
+    Tuple' c e <-
+        case dot of
+            Just 46 -> do
+                skip 1
+                P.takeWhile1
+                    (\w -> w - 48 <= 9)
+                    (Tuple' <$> foldToInteger n <*> FL.length)
+            _ -> return $ Tuple' n 0
+
+    let signedCoeff = if positive then c else (-c)
+    mex <- P.peekMaybe
+    case mex of
+        Just ex
+            | ex == 101 || ex == 69 -> do
+                skip 1
+                Sci.scientific signedCoeff . (e +) <$> parseDecimal
+        _ -> return (Sci.scientific signedCoeff e)
 
 {-# INLINE parseJsonString #-}
 parseJsonString :: MonadCatch m => Parser m Word8 JsonString
@@ -170,19 +168,24 @@ parseJsonString = do
     w <- P.peek
     case w of
         DOUBLE_QUOTE -> skip 1 >> return s
+        BACKSLASH -> (fmap (s <>) escapeParseJsonString) <* skip 1
         _ -> do
-            P.die $ [(chr . fromIntegral) w] ++ " Not yet implemented to handle escape sequences in String."
+            P.die $ [(chr . fromIntegral) w] ++ " : String without end."
+
+{-# INLINE escapeParseJsonString #-}
+escapeParseJsonString :: MonadCatch m => Parser m Word8 JsonString
+escapeParseJsonString = P.scan startState go (Uni.foldUtf8With A.unsafeWrite)
+  where
+    startState = False
+    go s a
+        | s = Just False
+        | a == DOUBLE_QUOTE = Nothing
+        | otherwise =
+            let a' = a == backslash
+             in Just a'
 
 {-# INLINE parseJsonValue #-}
 parseJsonValue :: MonadCatch m => Parser m Word8 Value
-{- parseJsonValue = skipSpace >>
-            (Object <$> parseJsonObject)
-    `P.alt` (Array  <$> parseJsonArray)
-    `P.alt` (String <$> parseJsonString)
-    `P.alt` (Number <$> parseJsonNumber)
-    `P.alt` (Bool True <$ string "true")
-    `P.alt` (Bool False <$ string "false")
-    `P.alt` (Null <$ string "null") -}
 parseJsonValue = do
     skipSpace
     w <- P.peek
@@ -230,13 +233,55 @@ parseJsonArray = do
     match CLOSE_SQUARE
     return jsonValues
 
+{-# INLINE parseJsonEOF #-}
+parseJsonEOF :: MonadCatch m => PR.Parser m Word8 Value
+parseJsonEOF =
+    P.toParserK $ do
+        v <- parseJsonValue
+        skipSpace
+        P.eof
+        return v
+
 {-# INLINE parseJson #-}
 parseJson :: MonadCatch m => PR.Parser m Word8 Value
--- parseJson = P.toParserK (spaceAround $ (Object <$> parseJsonObject) `P.alt` (Array <$> parseJsonArray))
-parseJson = P.toParserK $ do
-    skipSpace
-    w <- P.peek
-    case w of
-        OPEN_CURLY  -> Object <$> parseJsonObject
-        OPEN_SQUARE -> Array <$> parseJsonArray
-        _           -> P.die $ "Encountered " ++ [chr . fromIntegral $ w] ++ " when expection [ or {."
+parseJson = P.toParserK $ parseJsonValue
+
+{-
+
+{-# INLINE pushToFold #-}
+pushToFold :: Monad m => Fold m a b -> a -> Fold m a b
+pushToFold (Fold step initial extract) a = Fold step initial' extract
+    where
+    initial' = do
+        s <- initial
+        step s a
+
+sepBy1 ::
+       MonadCatch m
+    => Fold m a c
+    -> Parser m Word8 a
+    -> Parser m Word8 sep
+    -> Parser m Word8 c
+sepBy1 fl p sep = do
+    a <- p
+    P.many (pushToFold fl a) (sep >> p)
+
+sepBy ::
+       MonadCatch m
+    => Fold m a c
+    -> Parser m Word8 a
+    -> Parser m Word8 sep
+    -> Parser m Word8 c
+sepBy fl@(Fold _ initial extract) p sep =
+    sepBy1 fl p sep `P.alt` P.yieldM (initial >>= extract)
+
+parseJsonValue = skipSpace >>
+            (Object <$> parseJsonObject)
+    `P.alt` (Array  <$> parseJsonArray)
+    `P.alt` (String <$> parseJsonString)
+    `P.alt` (Number <$> parseJsonNumber)
+    `P.alt` (Bool True <$ string "true")
+    `P.alt` (Bool False <$ string "false")
+    `P.alt` (Null <$ string "null")
+
+-}

src/Streamly/Internal/Data/Parser.hs

@@ -62,8 +62,10 @@ module Streamly.Internal.Data.Parser
     , yieldM
     , die
     , dieM
+    , scan
 
     -- * Element parsers
+    , peekMaybe
     , peek
     , eof
     , satisfy
@@ -321,6 +323,10 @@ die = D.toParserK . D.die
 dieM :: MonadCatch m => m String -> Parser m a b
 dieM = D.toParserK . D.dieM
 
+{-# INLINE peekMaybe #-}
+peekMaybe :: MonadCatch m => Parser m a (Maybe a)
+peekMaybe = D.toParserK D.peekMaybe
+
 -------------------------------------------------------------------------------
 -- Failing Parsers
 -------------------------------------------------------------------------------
@@ -458,6 +464,12 @@ takeWhile cond = D.toParserK . D.takeWhile cond
 takeWhile1 :: MonadCatch m => (a -> Bool) -> Fold m a b -> Parser m a b
 takeWhile1 cond = D.toParserK . D.takeWhile1 cond
 
+-- /Internal/
+--
+{-# INLINE scan #-}
+scan :: MonadCatch m => s -> (s -> a -> Maybe s) -> Fold m a b -> Parser m a b
+scan s f fl = D.toParserK $ D.scan s f fl
+
 -- | @sepBy fl p sep@ collects zero or more stream elements separated by @sep@.
 --
 -- * Stops - when either of @p@ or @sep@ fails

src/Streamly/Internal/Data/Parser/ParserD.hs

@@ -27,8 +27,10 @@ module Streamly.Internal.Data.Parser.ParserD
     , yieldM
     , die
     , dieM
+    , scan
 
     -- * Element parsers
+    , peekMaybe
     , peek
     , eof
     , satisfy
@@ -249,6 +251,22 @@ all predicate = Parser step initial return
 
     step s a = return (if s && predicate a then Partial 0 True else Done 0 False)
 
+-- | See 'Streamly.Internal.Data.Parser.peekMaybe'.
+--
+-- /Internal/
+--
+{-# INLINABLE peekMaybe #-}
+peekMaybe :: MonadThrow m => Parser m a (Maybe a)
+peekMaybe = Parser step initial extract
+
+    where
+
+    initial = return ()
+
+    step () a = return $ Done 1 (Just a)
+
+    extract () = return Nothing
+
 -------------------------------------------------------------------------------
 -- Failing Parsers
 -------------------------------------------------------------------------------
@@ -450,6 +468,23 @@ takeWhile1 predicate (Fold fstep finitial fextract) =
     extract Nothing = throwM $ ParseError "takeWhile1: end of input"
     extract (Just s) = fextract s
 
+{-# INLINE scan #-}
+scan :: Monad m => s -> (s -> a -> Maybe s) -> Fold m a b -> Parser m a b
+scan begin sstep (Fold fstep finitial fextract) = Parser step initial extract
+
+  where
+
+    initial = Tuple' begin <$> finitial
+
+    step (Tuple' s fs) a =
+        case sstep s a of
+            Just s' -> do
+              fs' <- fstep fs a
+              return $ Partial 0 (Tuple' s' fs')
+            Nothing -> Done 1 <$> fextract fs
+
+    extract (Tuple' _ fs) = fextract fs
+
 {-# ANN type SepParseState Fuse #-}
 data SepParseState seps sa fs = SepParseA !Int fs sa | SepParseSep !Int fs seps
 
@@ -473,29 +508,29 @@ sepBy (Fold fstep finitial fextract) (Parser pstep pinitial pextract)
         ps <- pinitial
         return $ SepParseA 0 fs ps
 
-    step (SepParseA cnt fst pst) a = do
+    step (SepParseA cnt fs pst) a = do
         ps <- pstep pst a
         case ps of
-            Partial n s -> return $ Partial n (SepParseA 0 fst s)
-            Continue n s -> return $ Continue n (SepParseA (cnt + 1 - n) fst s)
+            Partial n s -> return $ Partial n (SepParseA 0 fs s)
+            Continue n s -> return $ Continue n (SepParseA (cnt + 1 - n) fs s)
             Done n b -> do
                 pseps <- psepinitial
-                fs <- fstep fst b
-                return $ Continue n (SepParseSep 0 fs pseps)
+                fs' <- fstep fs b
+                return $ Partial n (SepParseSep 0 fs' pseps)
             Error _ -> do
-                c <- fextract fst
+                c <- fextract fs
                 return $ Done (cnt + 1) c
 
-    step (SepParseSep cnt fst psepst) a = do
+    step (SepParseSep cnt fs psepst) a = do
         pseps <- psepstep psepst a
         case pseps of
-            Partial n s -> return $ Continue n (SepParseSep (cnt + 1 - n) fst s)
-            Continue n s -> return $ Continue n (SepParseSep (cnt + 1 - n) fst s)
+            Partial n s -> return $ Continue n (SepParseSep (cnt + 1 - n) fs s)
+            Continue n s -> return $ Continue n (SepParseSep (cnt + 1 - n) fs s)
             Done n _ -> do
                 ps <- pinitial
-                return $ Continue n (SepParseA (cnt + 1) fst ps)
+                return $ Continue n (SepParseA (cnt + 1 - n) fs ps)
             Error _ -> do
-                c <- fextract fst
+                c <- fextract fs
                 return $ Done (cnt + 1) c
 
     extract (SepParseA _ fs sa) = do