@@ -59,8 +59,9 @@ module Streamly.Internal.Data.Parser.Types
5959 )
6060where
6161
62−import Control.Exception (assert, Exception(..))
6362import Control.Applicative (Alternative(..))
63+import Control.Exception (assert, Exception(..))
64+import Control.Monad (MonadPlus(..))
6465import Control.Monad.Catch (MonadCatch, try, throwM, MonadThrow)
6566
6667import Fusion.Plugin.Types (Fuse(..))
@@ -454,7 +455,7 @@ dieM err =
454455-- Note: The implementation of '<|>' is not lazy in the second
455456-- argument. The following code will fail:
456457--
457−-- >>> S.parse (PR.satisfy (> 0) `<|>` undefined) $ S.fromList [1..10]
458+-- >>> S.parse (PR.satisfy (> 0) <|> undefined) $ S.fromList [1..10]
458459--
459460instance MonadCatch m => Alternative (Parser m a) where
460461 {-# INLINE empty #-}
@@ -468,3 +469,100 @@ instance MonadCatch m => Alternative (Parser m a) where
468469
469470 {-# INLINE some #-}
470471 some = splitSome toList
472+
473+{-# ANN type ConcatParseState Fuse #-}
474+data ConcatParseState sl p = ConcatParseL sl | ConcatParseR p
475+
476+-- Note: The monad instance has quadratic performance complexity. It works fine
477+-- for small number of compositions but for a scalable implementation we need a
478+-- CPS version.
479+
480+-- | Monad composition can be used for lookbehind parsers, we can make the
481+-- future parses depend on the previously parsed values.
482+--
483+-- If we have to parse "a9" or "9a" but not "99" or "aa" we can use the
484+-- following parser:
485+--
486+-- @
487+-- backtracking :: MonadCatch m => PR.Parser m Char String
488+-- backtracking =
489+-- sequence [PR.satisfy isDigit, PR.satisfy isAlpha]
490+-- '<|>'
491+-- sequence [PR.satisfy isAlpha, PR.satisfy isDigit]
492+-- @
493+--
494+-- We know that if the first parse resulted in a digit at the first place then
495+-- the second parse is going to fail. However, we waste that information and
496+-- parse the first character again in the second parse only to know that it is
497+-- not an alphabetic char. By using lookbehind in a 'Monad' composition we can
498+-- avoid redundant work:
499+--
500+-- @
501+-- data DigitOrAlpha = Digit Char | Alpha Char
502+--
503+-- lookbehind :: MonadCatch m => PR.Parser m Char String
504+-- lookbehind = do
505+-- x1 \<- Digit '<$>' PR.satisfy isDigit
506+-- '<|>' Alpha '<$>' PR.satisfy isAlpha
507+--
508+-- -- Note: the parse depends on what we parsed already
509+-- x2 <- case x1 of
510+-- Digit _ -> PR.satisfy isAlpha
511+-- Alpha _ -> PR.satisfy isDigit
512+--
513+-- return $ case x1 of
514+-- Digit x -> [x,x2]
515+-- Alpha x -> [x,x2]
516+-- @
517+--
518+instance Monad m => Monad (Parser m a) where
519+ {-# INLINE return #-}
520+ return = pure
521+
522+ -- (>>=) :: Parser m a b -> (b -> Parser m a c) -> Parser m a c
523+ {-# INLINE (>>=) #-}
524+ (Parser stepL initialL extractL) >>= func = Parser step initial extract
525+
526+ where
527+
528+ initial = ConcatParseL <$> initialL
529+
530+ step (ConcatParseL st) a = do
531+ r <- stepL st a
532+ return $ case r of
533+ Yield _ s -> Skip 0 (ConcatParseL s)
534+ Skip n s -> Skip n (ConcatParseL s)
535+ Stop n b -> Skip n (ConcatParseR (func b))
536+ Error err -> Error err
537+
538+ step (ConcatParseR (Parser stepR initialR extractR)) a = do
539+ st <- initialR
540+ r <- stepR st a
541+ return $ case r of
542+ Yield n s ->
543+ Yield n (ConcatParseR (Parser stepR (return s) extractR))
544+ Skip n s ->
545+ Skip n (ConcatParseR (Parser stepR (return s) extractR))
546+ Stop n b -> Stop n b
547+ Error err -> Error err
548+
549+ extract (ConcatParseR (Parser _ initialR extractR)) =
550+ initialR >>= extractR
551+
552+ extract (ConcatParseL sL) = extractL sL >>= f . func
553+
554+ where
555+
556+ f (Parser _ initialR extractR) = initialR >>= extractR
557+
558+-- | 'mzero' is same as 'empty', it aborts the parser. 'mplus' is same as
559+-- '<|>', it selects the first succeeding parser.
560+--
561+-- /Internal/
562+--
563+instance MonadCatch m => MonadPlus (Parser m a) where
564+ {-# INLINE mzero #-}
565+ mzero = die "mzero"
566+
567+ {-# INLINE mplus #-}
568+ mplus = alt