@@ -36,9 +36,9 @@
3636-- 'Step' functor provides the following commands to the fold driver
3737-- corresponding to the use cases outlined in the previous para:
3838--
39−-- 1. 'Continue': buffer the current input and go back to a previous
39+-- 1. 'Continue': buffer the current input and optionally go back to a previous
4040-- position in the stream
41−-- 2. 'Partial': buffer the current input and go back to a previous
41+-- 2. 'Partial': buffer the current input and optionally go back to a previous
4242-- position in the stream, drop the buffer before that position.
4343-- 3. 'Done': parser succeeded, returns how much input was leftover
4444-- 4. 'Error': indicates that the parser has failed without a result
@@ -111,7 +111,8 @@
111111
112112module Streamly.Internal.Data.Parser.ParserD.Types
113113 (
114− Step (..)
114+ Initial (..)
115+ , Step (..)
115116 , Parser (..)
116117 , ParseError (..)
117118
@@ -135,6 +136,7 @@ import Control.Applicative (Alternative(..))
135136import Control.Exception (assert, Exception(..))
136137import Control.Monad (MonadPlus(..))
137138import Control.Monad.Catch (MonadCatch, try, throwM, MonadThrow)
139+import Data.Bifunctor (Bifunctor(..))
138140import Fusion.Plugin.Types (Fuse(..))
139141import Streamly.Internal.Data.Fold.Types (Fold(..), toList)
140142import Streamly.Internal.Data.Tuple.Strict (Tuple3'(..))
@@ -151,6 +153,48 @@ import Prelude hiding (concatMap)
151153-- >>> import qualified Streamly.Internal.Data.Stream.IsStream as Stream (parse)
152154-- >>> import qualified Streamly.Internal.Data.Parser as Parser
153155
156+-- | The type of a 'Parser''s initial action.
157+--
158+-- /Internal/
159+--
160+{-# ANN type Initial Fuse #-}
161+data Initial s b
162+ = IPartial !s -- ^ Wait for step function to be called with state @s@.
163+ | IDone !b -- ^ Return a result right away without an input.
164+ | IError String -- ^ Return an error right away without an input.
165+
166+-- | @first@ maps on 'IPartial' and @second@ maps on 'IDone'.
167+--
168+-- /Internal/
169+--
170+instance Bifunctor Initial where
171+ {-# INLINE bimap #-}
172+ bimap f _ (IPartial a) = IPartial (f a)
173+ bimap _ g (IDone b) = IDone (g b)
174+ bimap _ _ (IError err) = IError err
175+
176+ {-# INLINE first #-}
177+ first f (IPartial a) = IPartial (f a)
178+ first _ (IDone x) = IDone x
179+ first _ (IError err) = IError err
180+
181+ {-# INLINE second #-}
182+ second _ (IPartial x) = IPartial x
183+ second f (IDone a) = IDone (f a)
184+ second _ (IError err) = IError err
185+
186+-- | Maps a function over the result held by 'IDone'.
187+--
188+-- @
189+-- fmap = 'second'
190+-- @
191+--
192+-- /Internal/
193+--
194+instance Functor (Initial s) where
195+ {-# INLINE fmap #-}
196+ fmap = second
197+
154198-- | The return type of a 'Parser' step.
155199--
156200-- The parse operation feeds the input stream to the parser one element at a
@@ -231,7 +275,7 @@ instance Functor (Step s) where
231275-- /Internal/
232276--
233277data Parser m a b =
234− forall s. Parser (s -> a -> m (Step s b)) (m s) (s -> m b)
278+ forall s. Parser (s -> a -> m (Step s b)) (m (Initial s b)) (s -> m b)
235279
236280-- | This exception is used for two purposes:
237281--
@@ -249,11 +293,12 @@ instance Exception ParseError where
249293
250294instance Functor m => Functor (Parser m a) where
251295 {-# INLINE fmap #-}
252− fmap f (Parser step1 initial extract) =
296+ fmap f (Parser step1 initial1 extract) =
253297 Parser step initial (fmap2 f extract)
254298
255299 where
256300
301+ initial = fmap2 f initial1
257302 step s b = fmap2 f (step1 s b)
258303 fmap2 g = fmap (fmap g)
259304
@@ -263,9 +308,7 @@ instance Functor m => Functor (Parser m a) where
263308--
264309{-# INLINE_NORMAL yield #-}
265310yield :: Monad m => b -> Parser m a b
266−yield b = Parser (\_ _ -> pure $ Done 1 b) -- step
267− (pure ()) -- initial
268− (\_ -> pure b) -- extract
311+yield b = Parser undefined (pure $ IDone b) undefined
269312
270313-- | See 'Streamly.Internal.Data.Parser.yieldM'.
271314--
@@ -273,9 +316,7 @@ yield b = Parser (\_ _ -> pure $ Done 1 b) -- step
273316--
274317{-# INLINE yieldM #-}
275318yieldM :: Monad m => m b -> Parser m a b
276−yieldM b = Parser (\_ _ -> Done 1 <$> b) -- step
277− (pure ()) -- initial
278− (const b) -- extract
319+yieldM b = Parser undefined (IDone <$> b) undefined
279320
280321-------------------------------------------------------------------------------
281322-- Sequential applicative
@@ -296,7 +337,7 @@ data SeqParseState sl f sr = SeqParseL sl | SeqParseR f sr
296337-- /Internal/
297338--
298339{-# INLINE splitWith #-}
299−splitWith :: Monad m
340+splitWith :: MonadThrow m
300341 => (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c
301342splitWith func (Parser stepL initialL extractL)
302343 (Parser stepR initialR extractR) =
@@ -304,38 +345,55 @@ splitWith func (Parser stepL initialL extractL)
304345
305346 where
306347
307− initial = SeqParseL <$> initialL
348+ initial = do
349+ resL <- initialL
350+ case resL of
351+ IPartial sl -> return $ IPartial $ SeqParseL sl
352+ IDone bl -> do
353+ resR <- initialR
354+ return $ case resR of
355+ IPartial sr -> IPartial $ SeqParseR (func bl) sr
356+ IDone br -> IDone (func bl br)
357+ IError err -> IError err
358+ IError err -> return $ IError err
308359
309360 -- Note: For the composed parse to terminate, the left parser has to be
310361 -- a terminating parser returning a Done at some point.
311− step (SeqParseL st) a = do
312− r <- stepL st a
313− case r of
362+ step (SeqParseL st) a =
363+ (\resL initR ->
364+ case resL of
314365 -- Note: We need to buffer the input for a possible Alternative
315366 -- e.g. in ((,) <$> p1 <*> p2) <|> p3, if p2 fails we have to
316367 -- backtrack and start running p3. So we need to keep the input
317368 -- buffered until we know that the applicative cannot fail.
318− Partial n s -> return $ Continue n (SeqParseL s)
319− Continue n s -> return $ Continue n (SeqParseL s)
320− Done n b -> Continue n <$> (SeqParseR (func b) <$> initialR)
321− Error err -> return $ Error err
369+ Partial n s -> Continue n (SeqParseL s)
370+ Continue n s -> Continue n (SeqParseL s)
371+ Done n b ->
372+ case initR of
373+ IPartial sr -> Continue n $ SeqParseR (func b) sr
374+ IDone br -> Done n (func b br)
375+ IError err -> Error err
376+ Error err -> Error err) <$> stepL st a <*> initialR
322377
323− step (SeqParseR f st) a = do
324− r <- stepR st a
325− return $ case r of
378+ step (SeqParseR f st) a =
379+ (\case
326380 Partial n s -> Partial n (SeqParseR f s)
327381 Continue n s -> Continue n (SeqParseR f s)
328382 Done n b -> Done n (f b)
329− Error err -> Error err
383+ Error err -> Error err) <$> stepR st a
330384
331385 extract (SeqParseR f sR) = fmap f (extractR sR)
332386 extract (SeqParseL sL) = do
333387 rL <- extractL sL
334− sR <- initialR
335− rR <- extractR sR
336− return $ func rL rR
337−
338−-- Only use this if you know what you're doing
388+ res <- initialR
389+ case res of
390+ IPartial sR -> do
391+ rR <- extractR sR
392+ return $ func rL rR
393+ IDone rR -> return $ func rL rR
394+ IError err -> throwM $ ParseError err
395+
396+-- | Works correctly only if the first parser is guaranteed to never fail.
339397{-# INLINE noErrorUnsafeSplitWith #-}
340398noErrorUnsafeSplitWith :: Monad m
341399 => (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c
@@ -345,14 +403,34 @@ noErrorUnsafeSplitWith func (Parser stepL initialL extractL)
345403
346404 where
347405
348− initial = SeqParseL <$> initialL
406+ initial = do
407+ resL <- initialL
408+ case resL of
409+ IPartial sl -> return $ IPartial $ SeqParseL sl
410+ IDone bl -> do
411+ resR <- initialR
412+ return $ case resR of
413+ IPartial sr -> IPartial $ SeqParseR (func bl) sr
414+ IDone br -> IDone (func bl br)
415+ IError err -> IError err
416+ IError err -> return $ IError err
349417
418+ -- Note: For the composed parse to terminate, the left parser has to be
419+ -- a terminating parser returning a Done at some point.
350420 step (SeqParseL st) a = do
351421 r <- stepL st a
352422 case r of
423+ -- Assume that the first parser can never fail, therefore we do not
424+ -- need to keep the input for backtracking.
353425 Partial n s -> return $ Partial n (SeqParseL s)
354426 Continue n s -> return $ Partial n (SeqParseL s)
355− Done n b -> Partial n <$> (SeqParseR (func b) <$> initialR)
427+ Done n b -> do
428+ res <- initialR
429+ return
430+ $ case res of
431+ IPartial sr -> Partial n $ SeqParseR (func b) sr
432+ IDone br -> Done n (func b br)
433+ IError err -> Error err
356434 Error err -> return $ Error err
357435
358436 step (SeqParseR f st) a = do
@@ -366,9 +444,15 @@ noErrorUnsafeSplitWith func (Parser stepL initialL extractL)
366444 extract (SeqParseR f sR) = fmap f (extractR sR)
367445 extract (SeqParseL sL) = do
368446 rL <- extractL sL
369− sR <- initialR
370− rR <- extractR sR
371− return $ func rL rR
447+ res <- initialR
448+ case res of
449+ IPartial sR -> do
450+ rR <- extractR sR
451+ return $ func rL rR
452+ IDone rR -> return $ func rL rR
453+ IError err -> error $ "noErrorUnsafeSplitWith: cannot use a "
454+ ++ "failing parser. Parser failed with: " ++ err
455+
372456
373457{-# ANN type SeqAState Fuse #-}
374458data SeqAState sl sr = SeqAL sl | SeqAR sr
@@ -379,23 +463,37 @@ data SeqAState sl sr = SeqAL sl | SeqAR sr
379463-- /Internal/
380464--
381465{-# INLINE split_ #-}
382−split_ :: Monad m => Parser m x a -> Parser m x b -> Parser m x b
466+split_ :: MonadThrow m => Parser m x a -> Parser m x b -> Parser m x b
383467split_ (Parser stepL initialL extractL) (Parser stepR initialR extractR) =
384468 Parser step initial extract
385469
386470 where
387471
388− initial = SeqAL <$> initialL
472+ initial = do
473+ resL <- initialL
474+ case resL of
475+ IPartial sl -> return $ IPartial $ SeqAL sl
476+ IDone _ -> do
477+ resR <- initialR
478+ return $ case resR of
479+ IPartial sr -> IPartial $ SeqAR sr
480+ IDone br -> IDone br
481+ IError err -> IError err
482+ IError err -> return $ IError err
389483
390484 -- Note: For the composed parse to terminate, the left parser has to be
391485 -- a terminating parser returning a Done at some point.
392486 step (SeqAL st) a =
393− (\r i -> case r of
487+ (\resL initR -> case resL of
394488 -- Note: this leads to buffering even if we are not in an
395489 -- Alternative composition.
396490 Partial n s -> Continue n (SeqAL s)
397491 Continue n s -> Continue n (SeqAL s)
398− Done n _ -> Continue n (SeqAR i)
492+ Done n _ -> do
493+ case initR of
494+ IPartial s -> Continue n (SeqAR s)
495+ IDone b -> Done n b
496+ IError err -> Error err
399497 -- XXX should we sequence initialR monadically?
400498 Error err -> Error err) <$> stepL st a <*> initialR
401499
@@ -409,10 +507,14 @@ split_ (Parser stepL initialL extractL) (Parser stepR initialR extractR) =
409507 extract (SeqAR sR) = extractR sR
410508 extract (SeqAL sL) = do
411509 _ <- extractL sL
412− initialR >>= extractR
510+ res <- initialR
511+ case res of
512+ IPartial sR -> extractR sR
513+ IDone rR -> return rR
514+ IError err -> throwM $ ParseError err
413515
414516-- | 'Applicative' form of 'splitWith'.
415−instance Monad m => Applicative (Parser m a) where
517+instance MonadThrow m => Applicative (Parser m a) where
416518 {-# INLINE pure #-}
417519 pure = yield
418520
@@ -445,7 +547,17 @@ alt (Parser stepL initialL extractL) (Parser stepR initialR extractR) =
445547
446548 where
447549
448− initial = AltParseL 0 <$> initialL
550+ initial = do
551+ resL <- initialL
552+ case resL of
553+ IPartial sl -> return $ IPartial $ AltParseL 0 sl
554+ IDone bl -> return $ IDone bl
555+ IError _ -> do
556+ resR <- initialR
557+ return $ case resR of
558+ IPartial sr -> IPartial $ AltParseR sr
559+ IDone br -> IDone br
560+ IError err -> IError err
449561
450562 -- Once a parser yields at least one value it cannot fail. This
451563 -- restriction helps us make backtracking more efficient, as we do not need
@@ -461,8 +573,12 @@ alt (Parser stepL initialL extractL) (Parser stepR initialR extractR) =
461573 return $ Continue n (AltParseL (cnt + 1 - n) s)
462574 Done n b -> return $ Done n b
463575 Error _ -> do
464− rR <- initialR
465− return $ Continue (cnt + 1) (AltParseR rR)
576+ res <- initialR
577+ return
578+ $ case res of
579+ IPartial rR -> Continue (cnt + 1) (AltParseR rR)
580+ IDone b -> Done (cnt + 1) b
581+ IError err -> Error err
466582
467583 step (AltParseR st) a = do
468584 r <- stepR st a
@@ -486,14 +602,25 @@ splitMany (Fold fstep finitial fextract) (Parser step1 initial1 extract1) =
486602
487603 where
488604
489− initial = do
490− ps <- initial1 -- parse state
491− res <- finitial -- fold state
492− return
493− $ case res of
494− FL.Partial fs -> Tuple3' ps (0 :: Int) fs
495− FL.Done _ ->
496− error "splitMany: Done in initial not implemented"
605+ -- Caution! There is mutual recursion here, inlining the right functions is
606+ -- important.
607+
608+ {-# INLINE handleCollect #-}
609+ handleCollect partial done fres =
610+ case fres of
611+ FL.Partial fs -> do
612+ pres <- initial1
613+ case pres of
614+ IPartial ps -> return $ partial $ Tuple3' ps 0 fs
615+ IDone pb ->
616+ runCollectorWith (handleCollect partial done) fs pb
617+ IError _ -> done <$> fextract fs
618+ FL.Done fb -> return $ done fb
619+
620+ -- Do not inline this
621+ runCollectorWith cont fs pb = fstep fs pb >>= cont
622+
623+ initial = finitial >>= handleCollect IPartial IDone
497624
498625 {-# INLINE step #-}
499626 step (Tuple3' st cnt fs) a = do
@@ -507,13 +634,8 @@ splitMany (Fold fstep finitial fextract) (Parser step1 initial1 extract1) =
507634 assert (cnt1 - n >= 0) (return ())
508635 return $ Continue n (Tuple3' s (cnt1 - n) fs)
509636 Done n b -> do
510− s <- initial1
511− fs1 <- fstep fs b
512637 assert (cnt1 - n >= 0) (return ())
513− return
514− $ case fs1 of
515− FL.Partial s1 -> Partial n (Tuple3' s 0 s1)
516− FL.Done b1 -> Done n b1
638+ fstep fs b >>= handleCollect (Partial n) (Done n)
517639 Error _ -> do
518640 xs <- fextract fs
519641 return $ Done cnt1 xs
@@ -540,14 +662,39 @@ splitSome (Fold fstep finitial fextract) (Parser step1 initial1 extract1) =
540662
541663 where
542664
665+ -- Caution! There is mutual recursion here, inlining the right functions is
666+ -- important.
667+
668+ {-# INLINE handleCollect #-}
669+ handleCollect partial done fres =
670+ case fres of
671+ FL.Partial fs -> do
672+ pres <- initial1
673+ case pres of
674+ IPartial ps -> return $ partial $ Tuple3' ps 0 $ Right fs
675+ IDone pb ->
676+ runCollectorWith (handleCollect partial done) fs pb
677+ IError _ -> done <$> fextract fs
678+ FL.Done fb -> return $ done fb
679+
680+ -- Do not inline this
681+ runCollectorWith cont fs pb = fstep fs pb >>= cont
682+
543683 initial = do
544− ps <- initial1 -- parse state
545− res <- finitial -- fold state
546− return
547− $ case res of
548− FL.Partial fs -> Tuple3' ps (0 :: Int) (Left fs)
549− FL.Done _ ->
550− error "splitSome: Done/Error in initial not implemented"
684+ fres <- finitial
685+ case fres of
686+ FL.Partial fs -> do
687+ pres <- initial1
688+ case pres of
689+ IPartial ps -> return $ IPartial $ Tuple3' ps 0 $ Left fs
690+ IDone pb ->
691+ runCollectorWith (handleCollect IPartial IDone) fs pb
692+ IError err -> return $ IError err
693+ FL.Done _ ->
694+ return
695+ $ IError
696+ $ "splitSome: The collecting fold terminated without"
697+ ++ " consuming any elements."
551698
552699 {-# INLINE step #-}
553700 step (Tuple3' st cnt (Left fs)) a = do
@@ -563,12 +710,7 @@ splitSome (Fold fstep finitial fextract) (Parser step1 initial1 extract1) =
563710 return $ Continue n (Tuple3' s (cnt1 - n) (Left fs))
564711 Done n b -> do
565712 assert (cnt1 - n >= 0) (return ())
566− s <- initial1
567− fs1 <- fstep fs b
568− return
569− $ case fs1 of
570− FL.Partial s1 -> Partial n (Tuple3' s 0 (Right s1))
571− FL.Done b1 -> Done n b1
713+ fstep fs b >>= handleCollect (Partial n) (Done n)
572714 Error err -> return $ Error err
573715 step (Tuple3' st cnt (Right fs)) a = do
574716 r <- step1 st a
@@ -582,12 +724,7 @@ splitSome (Fold fstep finitial fextract) (Parser step1 initial1 extract1) =
582724 return $ Continue n (Tuple3' s (cnt1 - n) (Right fs))
583725 Done n b -> do
584726 assert (cnt1 - n >= 0) (return ())
585− s <- initial1
586− fs1 <- fstep fs b
587− return
588− $ case fs1 of
589− FL.Partial s1 -> Partial n (Tuple3' s 0 (Right s1))
590− FL.Done b1 -> Done n b1
727+ fstep fs b >>= handleCollect (Partial n) (Done n)
591728 Error _ -> Done cnt1 <$> fextract fs
592729
593730 -- XXX The "try" may impact performance if this parser is used as a scan
@@ -613,10 +750,7 @@ splitSome (Fold fstep finitial fextract) (Parser step1 initial1 extract1) =
613750--
614751{-# INLINE_NORMAL die #-}
615752die :: MonadThrow m => String -> Parser m a b
616−die err =
617− Parser (\_ _ -> pure $ Error err) -- step
618− (pure ()) -- initial
619− (\_ -> throwM $ ParseError err) -- extract
753+die err = Parser undefined (pure (IError err)) undefined
620754
621755-- | See 'Streamly.Internal.Data.Parser.dieM'.
622756--
@@ -624,10 +758,7 @@ die err =
624758--
625759{-# INLINE dieM #-}
626760dieM :: MonadThrow m => m String -> Parser m a b
627−dieM err =
628− Parser (\_ _ -> Error <$> err) -- step
629− (pure ()) -- initial
630− (\_ -> err >>= throwM . ParseError) -- extract
761+dieM err = Parser undefined (IError <$> err) undefined
631762
632763-- Note: The default implementations of "some" and "many" loop infinitely
633764-- because of the strict pattern match on both the arguments in applicative and
@@ -659,47 +790,70 @@ instance MonadCatch m => Alternative (Parser m a) where
659790 some = splitSome toList
660791
661792{-# ANN type ConcatParseState Fuse #-}
662−data ConcatParseState sl p = ConcatParseL sl | ConcatParseR p
793+data ConcatParseState sl m a b =
794+ ConcatParseL sl
795+ | forall s. ConcatParseR (s -> a -> m (Step s b)) s (s -> m b)
663796
664797-- | See 'Streamly.Internal.Data.Parser.concatMap'.
665798--
666799-- /Internal/
667800--
668801{-# INLINE concatMap #-}
669−concatMap :: Monad m => (b -> Parser m a c) -> Parser m a b -> Parser m a c
802+concatMap :: MonadThrow m =>
803+ (b -> Parser m a c) -> Parser m a b -> Parser m a c
670804concatMap func (Parser stepL initialL extractL) = Parser step initial extract
671805
672806 where
673807
674− initial = ConcatParseL <$> initialL
808+ {-# INLINE initializeR #-}
809+ initializeR (Parser stepR initialR extractR) = do
810+ resR <- initialR
811+ return $ case resR of
812+ IPartial sr -> IPartial $ ConcatParseR stepR sr extractR
813+ IDone br -> IDone br
814+ IError err -> IError err
815+
816+ initial = do
817+ res <- initialL
818+ case res of
819+ IPartial s -> return $ IPartial $ ConcatParseL s
820+ IDone b -> initializeR (func b)
821+ IError err -> return $ IError err
822+
823+ {-# INLINE initializeRL #-}
824+ initializeRL n (Parser stepR initialR extractR) = do
825+ resR <- initialR
826+ return $ case resR of
827+ IPartial sr -> Continue n $ ConcatParseR stepR sr extractR
828+ IDone br -> Done n br
829+ IError err -> Error err
675830
676831 step (ConcatParseL st) a = do
677832 r <- stepL st a
678− return $ case r of
679− Partial n s -> Continue n (ConcatParseL s)
680− Continue n s -> Continue n (ConcatParseL s)
681− Done n b -> Continue n (ConcatParseR (func b))
682− Error err -> Error err
833+ case r of
834+ Partial n s -> return $ Continue n (ConcatParseL s)
835+ Continue n s -> return $ Continue n (ConcatParseL s)
836+ Done n b -> initializeRL n (func b)
837+ Error err -> return $ Error err
683838
684− step (ConcatParseR (Parser stepR initialR extractR)) a = do
685− st <- initialR
839+ step (ConcatParseR stepR st extractR) a = do
686840 r <- stepR st a
687841 return $ case r of
688− Partial n s ->
689− Partial n (ConcatParseR (Parser stepR (return s) extractR))
690− Continue n s ->
691− Continue n (ConcatParseR (Parser stepR (return s) extractR))
842+ Partial n s -> Partial n $ ConcatParseR stepR s extractR
843+ Continue n s -> Continue n $ ConcatParseR stepR s extractR
692844 Done n b -> Done n b
693845 Error err -> Error err
694846
695− extract (ConcatParseR (Parser _ initialR extractR)) =
696− initialR >>= extractR
697−
698− extract (ConcatParseL sL) = extractL sL >>= f . func
699−
700− where
847+ {-# INLINE extractP #-}
848+ extractP (Parser _ initialR extractR) = do
849+ res <- initialR
850+ case res of
851+ IPartial s -> extractR s
852+ IDone b -> return b
853+ IError err -> throwM $ ParseError err
701854
702− f (Parser _ initialR extractR) = initialR >>= extractR
855+ extract (ConcatParseR _ s extractR) = extractR s
856+ extract (ConcatParseL sL) = extractL sL >>= extractP . func
703857
704858-- Note: The monad instance has quadratic performance complexity. It works fine
705859-- for small number of compositions but for a scalable implementation we need a
@@ -707,7 +861,7 @@ concatMap func (Parser stepL initialL extractL) = Parser step initial extract
707861
708862-- | See documentation of 'Streamly.Internal.Data.Parser.ParserK.Types.Parser'.
709863--
710−instance Monad m => Monad (Parser m a) where
864+instance MonadThrow m => Monad (Parser m a) where
711865 {-# INLINE return #-}
712866 return = pure
713867