diff --git a/core/src/Streamly/Internal/Data/Array.hs b/core/src/Streamly/Internal/Data/Array.hs index ddf698cce6..3fcf7225c7 100644 --- a/core/src/Streamly/Internal/Data/Array.hs +++ b/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 diff --git a/core/src/Streamly/Internal/Data/Parser.hs b/core/src/Streamly/Internal/Data/Parser.hs index fae982235f..bfe0a4eb5e 100644 --- a/core/src/Streamly/Internal/Data/Parser.hs +++ b/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 diff --git a/core/src/Streamly/Internal/Data/Parser/Type.hs b/core/src/Streamly/Internal/Data/Parser/Type.hs index 0d24d210f4..8a9e56a518 100644 --- a/core/src/Streamly/Internal/Data/Parser/Type.hs +++ b/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 diff --git a/core/src/Streamly/Internal/Data/Stream/Eliminate.hs b/core/src/Streamly/Internal/Data/Stream/Eliminate.hs index 7d47588ccb..95bc957a02 100644 --- a/core/src/Streamly/Internal/Data/Stream/Eliminate.hs +++ b/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 diff --git a/core/src/Streamly/Internal/Data/StreamK.hs b/core/src/Streamly/Internal/Data/StreamK.hs index a80422d98f..78c0891057 100644 --- a/core/src/Streamly/Internal/Data/StreamK.hs +++ b/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 diff --git a/streamly.cabal b/streamly.cabal index 87e264f314..6f0d82d858 100644 --- a/streamly.cabal +++ b/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 diff --git a/test/Streamly/Test/Data/Parser.hs b/test/Streamly/Test/Data/Parser.hs index f5b08a69a4..6bb7b9294d 100644 --- a/test/Streamly/Test/Data/Parser.hs +++ b/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