Add an elaborate parser driver sanity tests

core/src/Streamly/Internal/Data/Array.hs

@@ -966,7 +966,7 @@ parseBreakChunksK (Parser pstep initial extract) stream = do
                 let n = Prelude.length backBuf
                     arr0 = fromListN n (Prelude.reverse backBuf)
                     arr1 = Array contents cur end
-                    str = StreamK.cons arr0 (StreamK.cons arr1 stream)
+                    str = StreamK.cons arr0 (StreamK.cons arr1 st)
                 return (Left (ParseError err), str)
 
     -- This is a simplified goArray
@@ -1000,7 +1000,7 @@ parseBreakChunksK (Parser pstep initial extract) stream = do
                 return (Right b, StreamK.fromPure arr)
             Parser.Done n b -> do
                 assert (n <= Prelude.length backBuf) (return ())
-                let src0 = Prelude.take n backBuf
+                let src0 = Prelude.take n (x:backBuf)
                     -- XXX Use fromListRevN once implemented
                     -- arr0 = A.fromListRevN n src0
                     arr0 = fromListN n (Prelude.reverse src0)
@@ -1011,7 +1011,7 @@ parseBreakChunksK (Parser pstep initial extract) stream = do
                 let n = Prelude.length backBuf
                     arr0 = fromListN n (Prelude.reverse backBuf)
                     arr1 = Array contents cur end
-                    str = StreamK.cons arr0 (StreamK.cons arr1 stream)
+                    str = StreamK.cons arr0 (StreamK.fromPure arr1)
                 return (Left (ParseError err), str)
 
     -- This is a simplified goExtract

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

@@ -1766,17 +1766,15 @@ wordWithQuotes keepQuotes tr escChar toRight isSep
                 FL.Done b -> Done 0 b
 
     {-# INLINE checkRightQuoteAndProcess #-}
-    checkRightQuoteAndProcess s a n ql qr =
-        if a == qr
-        then
+    checkRightQuoteAndProcess s a n ql qr
+        | a == qr =
            if n == 1
            then if keepQuotes
                 then processUnquoted s a
                 else return $ Continue 0 $ WordUnquotedWord s
            else processQuoted s a (n - 1) ql qr
-        else if a == ql
-             then processQuoted s a (n + 1) ql qr
-             else processQuoted s a n ql qr
+        | a == ql = processQuoted s a (n + 1) ql qr
+        | otherwise = processQuoted s a n ql qr
 
     step (WordQuotedSkipPre s) a
         | isEsc a = return $ Continue 0 $ WordUnquotedEsc s

core/src/Streamly/Internal/Data/Parser/Type.hs

@@ -350,6 +350,7 @@ data Step s b =
     --
     -- The parsing operation may backtrack to the beginning and try another
     -- alternative.
+    deriving (Show)
 
 -- | Map first function over the state and second over the result.
 instance Bifunctor Step where
@@ -455,7 +456,7 @@ data Fold m a b =
 -- /Pre-release/
 --
 newtype ParseError = ParseError String
-    deriving Show
+    deriving (Eq, Show)
 
 instance Exception ParseError where
     displayException (ParseError err) = err

core/src/Streamly/Internal/Data/Stream/Eliminate.hs

@@ -278,7 +278,7 @@ parseBreakD (PRD.Parser pstep initial extract) stream@(Stream step state) = do
             PR.Done n b -> do
                 assert (n <= length (x:getList buf)) (return ())
                 let src0 = Prelude.take n (x:getList buf)
-                    src  = Prelude.reverse src0
+                    src  = Prelude.reverse src0 ++ xs
                 return (Right b, Nesting.append (fromList src) (Stream step s))
             PR.Error err -> do
                 let src = Prelude.reverse (getList buf) ++ x:xs
@@ -311,7 +311,7 @@ parseBreakD (PRD.Parser pstep initial extract) stream@(Stream step state) = do
             PR.Done n b -> do
                 assert (n <= length (x:getList buf)) (return ())
                 let src0 = Prelude.take n (x:getList buf)
-                    src  = Prelude.reverse src0
+                    src  = Prelude.reverse src0 ++ xs
                 return (Right b, fromList src)
             PR.Error err -> do
                 let src = Prelude.reverse (getList buf) ++ x:xs

core/src/Streamly/Internal/Data/StreamK.hs

@@ -1259,7 +1259,7 @@ parseDBreak (PR.Parser pstep initial extract) stream = do
             PR.Done n b -> do
                 assert (n <= length (x:buf)) (return ())
                 let src0 = Prelude.take n (x:buf)
-                    src  = Prelude.reverse src0
+                    src  = Prelude.reverse src0 ++ xs
                 return (Right b, append (fromList src) st)
             PR.Error err -> do
                 let src = Prelude.reverse buf ++ x:xs

streamly.cabal

@@ -72,6 +72,7 @@ extra-source-files:
     benchmark/bench-runner/Main.hs
     benchmark/bench-runner/bench-runner.cabal
     benchmark/Streamly/Benchmark/Data/*.hs
+    benchmark/Streamly/Benchmark/Data/Fold/*.hs
     benchmark/Streamly/Benchmark/Data/Serialize/*.hs
     benchmark/Streamly/Benchmark/Data/Array/Common.hs
     benchmark/Streamly/Benchmark/Data/Array/CommonImports.hs

test/Streamly/Test/Data/Parser.hs

@@ -26,6 +26,8 @@ import qualified Streamly.Internal.Data.Fold as FL
 import qualified Streamly.Internal.Data.Parser as P
 import qualified Streamly.Internal.Data.Producer as Producer
 import qualified Streamly.Internal.Data.Unfold as Unfold
+import qualified Streamly.Internal.Data.Stream as SI
+import qualified Streamly.Internal.Data.StreamK as K
 import qualified Test.Hspec as H
 
 import Test.Hspec
@@ -1300,6 +1302,210 @@ quotedWordTest inp expected = do
             trEsc _ _ = Nothing
          in P.wordWithQuotes False trEsc '\\' toRQuote isSpace FL.toList
 
+--------------------------------------------------------------------------------
+-- Parser sanity tests
+--------------------------------------------------------------------------------
+
+data Move
+    = Consume Int
+    | Custom (P.Step () ())
+    deriving (Show)
+
+jumpParser :: Monad m => [Move] -> P.Parser Int m [Int]
+jumpParser jumps = P.Parser step initial done
+    where
+    initial = pure $ P.IPartial (jumps, [])
+
+    step ([], buf) _ = pure $ P.Done 1 (reverse buf)
+    step (action:xs, buf) a =
+        case action of
+            Consume n
+                | n == 1 -> pure $ P.Continue 0 (xs, a:buf)
+                | n > 0 -> pure $ P.Continue 0 (Consume (n - 1) : xs, a:buf)
+                | otherwise -> error "Cannot consume <= 0"
+            Custom (P.Partial i ()) -> pure $ P.Partial i (xs, buf)
+            Custom (P.Continue i ()) -> pure $ P.Continue i (xs, buf)
+            Custom (P.Done i ()) -> pure $ P.Done i (reverse buf)
+            Custom (P.Error err) -> pure $ P.Error err
+
+    done ([], buf) = pure $ P.Done 0 (reverse buf)
+    done (action:xs, buf) =
+        case action of
+            Consume _ -> pure $ P.Error "INCOMPLETE"
+            Custom (P.Partial i ()) -> pure $ P.Partial i (xs, buf)
+            Custom (P.Continue i ()) -> pure $ P.Continue i (xs, buf)
+            Custom (P.Done i ()) -> pure $ P.Done i (reverse buf)
+            Custom (P.Error err) -> pure $ P.Error err
+
+chunkedTape :: [[Int]]
+chunkedTape = Prelude.map (\x -> [x..(x+9)]) [1, 11 .. 91]
+
+tape :: [Int]
+tape = concat chunkedTape
+
+tapeLen :: Int
+tapeLen = length tape
+
+expectedResult :: [Move] -> [Int] -> (Either ParseError [Int], [Int])
+expectedResult moves inp = go 0 0 [] moves
+    where
+    inpLen = length inp
+
+    slice off len = Prelude.take len . Prelude.drop off
+    slice_ off = Prelude.drop off
+
+    -- i = Index of inp head
+    -- j = Minimum index of inp head
+    go i j ys [] = (Right ys, slice_ (max i j) inp)
+    go i j ys ((Consume n):xs)
+        | i + n > inpLen = (Left (ParseError "INCOMPLETE"), drop j inp)
+        | otherwise =
+            go (i + n) j (ys ++ slice i n inp) xs
+    go i j ys ((Custom step):xs)
+        | i > inpLen = error "i > inpLen"
+        | i == inpLen =
+              -- Where there is no input we do not move forward by default.
+              -- Hence it is (i - n) and not (i + 1 - n)
+              case step of
+                  P.Partial n () -> go (i - n) (max j (i - n)) ys xs
+                  P.Continue n () -> go (i - n) j ys xs
+                  P.Done n () -> (Right ys, slice_ (max (i - n) j) inp)
+                  P.Error err -> (Left (ParseError err), slice_ j inp)
+        | otherwise =
+              case step of
+                  P.Partial n () -> go (i + 1 - n) (max j (i + 1 - n)) ys xs
+                  P.Continue n () -> go (i + 1 - n) j ys xs
+                  P.Done n () -> (Right ys, slice_ (max (i - n + 1) j) inp)
+                  P.Error err -> (Left (ParseError err), slice_ j inp)
+
+expectedResultMany :: [Move] -> [Int] -> [Either ParseError [Int]]
+expectedResultMany _ [] = []
+expectedResultMany moves inp =
+    let (res, rest) = expectedResult moves inp
+     in
+       case res of
+           Left err -> [Left err]
+           Right val -> Right val : expectedResultMany moves rest
+
+createPaths :: [a] -> [[a]]
+createPaths xs =
+    Prelude.map (flip Prelude.take xs) [1..length xs]
+
+parserSanityTests :: String -> ([Move] -> SpecWith ()) -> SpecWith ()
+parserSanityTests desc testRunner =
+    describe desc $ do
+        Prelude.mapM_ testRunner $
+            createPaths
+                [ Consume (tapeLen + 1)
+                ]
+        Prelude.mapM_ testRunner $
+            createPaths
+                [ Custom (P.Error "Message0")
+                ]
+        Prelude.mapM_ testRunner $
+            createPaths
+                [ Consume 10
+                , Custom (P.Partial 0 ())
+                , Consume 10
+                , Custom (P.Partial 1 ())
+                , Consume 10
+                , Custom (P.Partial 11 ())
+                , Consume 10
+                , Custom (P.Continue 0 ())
+                , Consume 10
+                , Custom (P.Continue 1 ())
+                , Consume 10
+                , Custom (P.Continue 11 ())
+                , Custom (P.Error "Message1")
+                ]
+        Prelude.mapM_ testRunner $
+            createPaths
+                [ Consume 10
+                , Custom (P.Continue 0 ())
+                , Consume 10
+                , Custom (P.Continue 1 ())
+                , Consume 10
+                , Custom (P.Continue 11 ())
+                , Consume 10
+                , Custom (P.Done 0 ())
+                ]
+        Prelude.mapM_ testRunner $
+            createPaths
+                [ Consume 20
+                , Custom (P.Continue 0 ())
+                , Custom (P.Continue 11 ())
+                , Custom (P.Done 1 ())
+                ]
+        Prelude.mapM_ testRunner $
+            createPaths
+                [ Consume 20
+                , Custom (P.Continue 0 ())
+                , Custom (P.Continue 11 ())
+                , Custom (P.Error "Message2")
+                ]
+        Prelude.mapM_ testRunner $
+            createPaths
+                [ Consume 20
+                , Custom (P.Continue 0 ())
+                , Custom (P.Continue 11 ())
+                , Custom (P.Done 5 ())
+                ]
+        Prelude.mapM_ testRunner $
+            createPaths
+                [ Consume tapeLen
+                , Custom (P.Continue 0 ())
+                , Custom (P.Continue 10 ())
+                , Custom (P.Done 5 ())
+                ]
+        Prelude.mapM_ testRunner $
+            createPaths
+                [ Consume tapeLen
+                , Custom (P.Continue 0 ())
+                , Custom (P.Continue 10 ())
+                , Custom (P.Error "Message3")
+                ]
+
+{-
+TODO:
+Add sanity tests for
+- Producer.parse
+- Producer.parseMany
+- Stream.parseMany
+- Stream.parseIterate
+-}
+
+sanityParseBreak :: [Move] -> SpecWith ()
+sanityParseBreak jumps = it (show jumps) $ do
+    (val, rest) <- SI.parseBreak (jumpParser jumps) $ S.fromList tape
+    lst <- S.toList rest
+    (val, lst) `shouldBe` (expectedResult jumps tape)
+
+sanityParseDBreak :: [Move] -> SpecWith ()
+sanityParseDBreak jumps = it (show jumps) $ do
+    (val, rest) <- K.parseDBreak (jumpParser jumps) $ K.fromList tape
+    lst <- K.toList rest
+    (val, lst) `shouldBe` (expectedResult jumps tape)
+
+sanityParseBreakChunksK :: [Move] -> SpecWith ()
+sanityParseBreakChunksK jumps = it (show jumps) $ do
+    (val, rest) <-
+        A.parseBreakChunksK (jumpParser jumps)
+            $ K.fromList $ Prelude.map A.fromList chunkedTape
+    lst <- Prelude.map A.toList <$> K.toList rest
+    (val, concat lst) `shouldBe` (expectedResult jumps tape)
+
+sanityParseMany :: [Move] -> SpecWith ()
+sanityParseMany jumps = it (show jumps) $ do
+    res <- S.toList $ SI.parseMany (jumpParser jumps) $ S.fromList tape
+    res `shouldBe` (expectedResultMany jumps tape)
+
+sanityParseIterate :: [Move] -> SpecWith ()
+sanityParseIterate jumps = it (show jumps) $ do
+    res <-
+        S.toList
+             $ SI.parseIterate (const (jumpParser jumps)) [] $ S.fromList tape
+    res `shouldBe` (expectedResultMany jumps tape)
+
 -------------------------------------------------------------------------------
 -- Main
 -------------------------------------------------------------------------------
@@ -1313,7 +1519,11 @@ main =
   H.parallel $
   modifyMaxSuccess (const maxTestCount) $ do
   describe moduleName $ do
-
+    parserSanityTests "Stream.parseBreak" sanityParseBreak
+    parserSanityTests "StreamK.parseDBreak" sanityParseDBreak
+    parserSanityTests "A.sanityParseBreakChunksK" sanityParseBreakChunksK
+    parserSanityTests "Stream.parseMany" sanityParseMany
+    parserSanityTests "Stream.parseIterate" sanityParseIterate
     describe "Instances" $ do
         prop "applicative" applicative
         prop "Alternative: end of input 1" altEOF1