{-# LANGUAGE ExistentialQuantification          #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- Module      : Streamly.Parser.Types
-- Copyright   : (c) 2020 Composewell Technologies
-- License     : BSD3
-- Maintainer  : streamly@composewell.com
-- Stability   : experimental
-- Portability : GHC
--
-- Streaming and backtracking parsers.
--
-- Parsers just extend folds.  Please read the 'Fold' design notes in
-- "Streamly.Internal.Data.Fold.Types" for background on the design.
--
-- = Parser Design
--
-- The 'Parser' type or a parsing fold is a generalization of the 'Fold' type.
-- The 'Fold' type /always/ succeeds on each input. Therefore, it does not need
-- to buffer the input. In contrast, a 'Parser' may fail and backtrack to
-- replay the input again to explore another branch of the parser. Therefore,
-- it needs to buffer the input. Therefore, a 'Parser' is a fold with some
-- additional requirements.  To summarize, unlike a 'Fold', a 'Parser':
--
-- 1. may not generate a new value of the accumulator on every input, it may
-- generate a new accumulator only after consuming multiple input elements
-- (e.g. takeEQ).
-- 2. on success may return some unconsumed input (e.g. takeWhile)
-- 3. may fail and return all input without consuming it (e.g. satisfy)
-- 4. backtrack and start inspecting the past input again (e.g. alt)
--
-- These use cases require buffering and replaying of input.  To facilitate
-- this, the step function of the 'Fold' is augmented to return the next state
-- of the fold along with a command tag using a 'Step' functor, the tag tells
-- the fold driver to manipulate the future input as the parser wishes. The
-- 'Step' functor provides the following commands to the fold driver
-- corresponding to the use cases outlined in the previous para:
--
-- 1. 'Skip': hold (buffer) the input or go back to a previous position in the stream
-- 2. 'Yield', 'Stop': tell how much input is unconsumed
-- 3. 'Error': indicates that the parser has failed without a result
--
-- = How a Parser Works?
--
-- A parser is just like a fold, it keeps consuming inputs from the stream and
-- accumulating them in an accumulator. The accumulator of the parser could be
-- a singleton value or it could be a collection of values e.g. a list.
--
-- The parser may build a new output value from multiple input items. When it
-- consumes an input item but needs more input to build a complete output item
-- it uses @Skip 0 s@, yielding the intermediate state @s@ and asking the
-- driver to provide more input.  When the parser determines that a new output
-- value is complete it can use a @Stop n b@ to terminate the parser with @n@
-- items of input unused and the final value of the accumulator returned as
-- @b@. If at any time the parser determines that the parse has failed it can
-- return @Error err@.
--
-- A parser building a collection of values (e.g. a list) can use the @Yield@
-- constructor whenever a new item in the output collection is generated. If a
-- parser building a collection of values has yielded at least one value then
-- it considered successful and cannot fail after that. In the current
-- implementation, this is not automatically enforced, there is a rule that the
-- parser MUST use only @Stop@ for termination after the first @Yield@, it
-- cannot use @Error@. It may be possible to change the implementation so that
-- this rule is not required, but there may be some performance cost to it.
--
-- 'Streamly.Internal.Data.Parser.takeWhile' and
-- 'Streamly.Internal.Data.Parser.some' combinators are good examples of
-- efficient implementations using all features of this representation.  It is
-- possible to idiomatically build a collection of parsed items using a
-- singleton parser and @Alternative@ instance instead of using a
-- multi-yield parser.  However, this implementation is amenable to stream
-- fusion and can therefore be much faster.
--
-- = Error Handling
--
-- When a parser's @step@ function is invoked it may iterminate by either a
-- 'Stop' or an 'Error' return value. In an 'Alternative' composition an error
-- return can make the composed parser backtrack and try another parser.
--
-- If the stream stops before a parser could terminate then we use the
-- @extract@ function of the parser to retrieve the last yielded value of the
-- parser. If the parser has yielded at least one value then @extract@ MUST
-- return a value without throwing an error, otherwise it uses the 'ParseError'
-- exception to throw an error.
--
-- We chose the exception throwing mechanism for @extract@ instead of using an
-- explicit error return via an 'Either' type for keeping the interface simple
-- as most of the time we do not need to catch the error in intermediate
-- layers. Note that we cannot use exception throwing mechanism in @step@
-- function because of performance reasons. 'Error' constructor in that case
-- allows loop fusion and better performance.
--
-- = Future Work
--
-- It may make sense to move "takeWhile" type of parsers, which cannot fail but
-- need some lookahead, to splitting folds.  This will allow such combinators
-- to be accepted where we need an unfailing "Fold" type.
--
-- Based on application requirements it should be possible to design even a
-- richer interface to manipulate the input stream/buffer. For example, we
-- could randomly seek into the stream in the forward or reverse directions or
-- we can even seek to the end or from the end or seek from the beginning.
--
-- We can distribute and scan/parse a stream using both folds and parsers and
-- merge the resulting streams using different merge strategies (e.g.
-- interleaving or serial).

module Streamly.Internal.Data.Parser.Types
    (
      Step (..)
    , Parser (..)
    , ParseError (..)

    , yield
    , yieldM
    , splitWith

    , die
    , dieM
    , splitSome
    , splitMany
    , alt
    )
where

import Control.Applicative (Alternative(..))
import Control.Exception (assert, Exception(..))
import Control.Monad (MonadPlus(..))
import Control.Monad.Catch (MonadCatch, try, throwM, MonadThrow)

import Fusion.Plugin.Types (Fuse(..))
import Streamly.Internal.Data.Fold (Fold(..), toList)
import Streamly.Internal.Data.Strict (Tuple3'(..))

-- | The return type of a 'Parser' step.
--
-- A parser is driven by a parse driver one step at a time, at any time the
-- driver may @extract@ the result of the parser. The parser may ask the driver
-- to backtrack at any point, therefore, the driver holds the input up to a
-- point of no return in a backtracking buffer.  The buffer grows or shrinks
-- based on the return values of the parser step execution.
--
-- When a parser step is executed it generates a new intermediate state of the
-- parse result along with a command to the driver. The command tells the
-- driver whether to keep the input stream for a potential backtracking later
-- on or drop it, and how much to keep. The constructors of 'Step' represent
-- the commands to the driver.
--
-- /Internal/
--
{-# ANN type Step Fuse #-}
data Step s b =
      Yield Int s
      -- ^ @Yield offset state@ indicates that the parser has yielded a new
      -- result which is a point of no return. The result can be extracted
      -- using @extract@. The driver drops the buffer except @offset@ elements
      -- before the current position in stream. The rule is that if a parser
      -- has yielded at least once it cannot return a failure result.

    | Skip Int s
    -- ^ @Skip offset state@ indicates that the parser has consumed the current
    -- input but no new result has been generated. A new @state@ is generated.
    -- However, if we use @extract@ on @state@ it will generate a result from
    -- the previous @Yield@.  When @offset@ is non-zero it is a backward offset
    -- from the current position in the stream from which the driver will feed
    -- the next input to the parser. The offset cannot be beyond the latest
    -- point of no return created by @Yield@.

    | Stop Int b
    -- ^ @Stop offset result@ asks the driver to stop driving the parser
    -- because it has reached a fixed point and further input will not change
    -- the result.  @offset@ is the count of unused elements which includes the
    -- element on which 'Stop' occurred.
    | Error String
    -- ^ An error makes the parser backtrack to the last checkpoint and try
    -- another alternative.

instance Functor (Step s) where
    {-# INLINE fmap #-}
    fmap :: (a -> b) -> Step s a -> Step s b
fmap a -> b
_ (Yield Int
n s
s) = Int -> s -> Step s b
forall s b. Int -> s -> Step s b
Yield Int
n s
s
    fmap a -> b
_ (Skip Int
n s
s) = Int -> s -> Step s b
forall s b. Int -> s -> Step s b
Skip Int
n s
s
    fmap a -> b
f (Stop Int
n a
b) = Int -> b -> Step s b
forall s b. Int -> b -> Step s b
Stop Int
n (a -> b
f a
b)
    fmap a -> b
_ (Error String
err) = String -> Step s b
forall s b. String -> Step s b
Error String
err

-- | A parser is a fold that can fail and is represented as @Parser step
-- initial extract@. Before we drive a parser we call the @initial@ action to
-- retrieve the initial state of the fold. The parser driver invokes @step@
-- with the state returned by the previous step and the next input element. It
-- results into a new state and a command to the driver represented by 'Step'
-- type. The driver keeps invoking the step function until it stops or fails.
-- At any point of time the driver can call @extract@ to inspect the result of
-- the fold. It may result in an error or an output value.
--
-- /Internal/
--
data Parser m a b =
    forall s. Parser (s -> a -> m (Step s b)) (m s) (s -> m b)

-- | This exception is used for two purposes:
--
-- * When a parser ultimately fails, the user of the parser is intimated via
--    this exception.
-- * When the "extract" function of a parser needs to throw an error.
--
-- /Internal/
--
newtype ParseError = ParseError String
    deriving Int -> ParseError -> ShowS
[ParseError] -> ShowS
ParseError -> String
(Int -> ParseError -> ShowS)
-> (ParseError -> String)
-> ([ParseError] -> ShowS)
-> Show ParseError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParseError] -> ShowS
$cshowList :: [ParseError] -> ShowS
show :: ParseError -> String
$cshow :: ParseError -> String
showsPrec :: Int -> ParseError -> ShowS
$cshowsPrec :: Int -> ParseError -> ShowS
Show

instance Exception ParseError where
    displayException :: ParseError -> String
displayException (ParseError String
err) = String
err

instance Functor m => Functor (Parser m a) where
    {-# INLINE fmap #-}
    fmap :: (a -> b) -> Parser m a a -> Parser m a b
fmap a -> b
f (Parser s -> a -> m (Step s a)
step1 m s
initial s -> m a
extract) =
        (s -> a -> m (Step s b)) -> m s -> (s -> m b) -> Parser m a b
forall (m :: * -> *) a b s.
(s -> a -> m (Step s b)) -> m s -> (s -> m b) -> Parser m a b
Parser s -> a -> m (Step s b)
step m s
initial ((a -> b) -> (s -> m a) -> s -> m b
forall (f :: * -> *) (f :: * -> *) a b.
(Functor f, Functor f) =>
(a -> b) -> f (f a) -> f (f b)
fmap2 a -> b
f s -> m a
extract)

        where

        step :: s -> a -> m (Step s b)
step s
s a
b = (a -> b) -> m (Step s a) -> m (Step s b)
forall (f :: * -> *) (f :: * -> *) a b.
(Functor f, Functor f) =>
(a -> b) -> f (f a) -> f (f b)
fmap2 a -> b
f (s -> a -> m (Step s a)
step1 s
s a
b)
        fmap2 :: (a -> b) -> f (f a) -> f (f b)
fmap2 a -> b
g = (f a -> f b) -> f (f a) -> f (f b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
g)

-- This is the dual of stream "yield".
--
-- | A parser that always yields a pure value without consuming any input.
--
-- /Internal/
--
{-# INLINE yield #-}
yield :: Monad m => b -> Parser m a b
yield :: b -> Parser m a b
yield b
b = (() -> a -> m (Step () b)) -> m () -> (() -> m b) -> Parser m a b
forall (m :: * -> *) a b s.
(s -> a -> m (Step s b)) -> m s -> (s -> m b) -> Parser m a b
Parser (\()
_ a
_ -> Step () b -> m (Step () b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Step () b -> m (Step () b)) -> Step () b -> m (Step () b)
forall a b. (a -> b) -> a -> b
$ Int -> b -> Step () b
forall s b. Int -> b -> Step s b
Stop Int
1 b
b)  -- step
                 (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())                  -- initial
                 (\()
_ -> b -> m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b)             -- extract

-- This is the dual of stream "yieldM".
--
-- | A parser that always yields the result of an effectful action without
-- consuming any input.
--
-- /Internal/
--
{-# INLINE yieldM #-}
yieldM :: Monad m => m b -> Parser m a b
yieldM :: m b -> Parser m a b
yieldM m b
b = (() -> a -> m (Step () b)) -> m () -> (() -> m b) -> Parser m a b
forall (m :: * -> *) a b s.
(s -> a -> m (Step s b)) -> m s -> (s -> m b) -> Parser m a b
Parser (\()
_ a
_ -> Int -> b -> Step () b
forall s b. Int -> b -> Step s b
Stop Int
1 (b -> Step () b) -> m b -> m (Step () b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m b
b) -- step
                  (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())              -- initial
                  (\()
_ -> m b
b)              -- extract

-------------------------------------------------------------------------------
-- Sequential applicative
-------------------------------------------------------------------------------

{-# ANN type SeqParseState Fuse #-}
data SeqParseState sl f sr = SeqParseL sl | SeqParseR f sr

-- Note: this implementation of splitWith is fast because of stream fusion but
-- has quadratic time complexity, because each composition adds a new branch
-- that each subsequent parse's input element has to go through, therefore, it
-- cannot scale to a large number of compositions. After around 100
-- compositions the performance starts dipping rapidly beyond a CPS style
-- unfused implementation.
--
-- | Sequential application. Apply two parsers sequentially to an input stream.
-- The input is provided to the first parser, when it is done the remaining
-- input is provided to the second parser. If both the parsers succeed their
-- outputs are combined using the supplied function. The operation fails if any
-- of the parsers fail.
--
-- This undoes an "append" of two streams, it splits the streams using two
-- parsers and zips the results.
--
-- This implementation is strict in the second argument, therefore, the
-- following will fail:
--
-- >>> S.parse (PR.satisfy (> 0) *> undefined) $ S.fromList [1]
--
-- /Internal/
--
{-# INLINE splitWith #-}
splitWith :: Monad m
    => (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c
splitWith :: (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c
splitWith a -> b -> c
func (Parser s -> x -> m (Step s a)
stepL m s
initialL s -> m a
extractL)
               (Parser s -> x -> m (Step s b)
stepR m s
initialR s -> m b
extractR) =
    (SeqParseState s (b -> c) s
 -> x -> m (Step (SeqParseState s (b -> c) s) c))
-> m (SeqParseState s (b -> c) s)
-> (SeqParseState s (b -> c) s -> m c)
-> Parser m x c
forall (m :: * -> *) a b s.
(s -> a -> m (Step s b)) -> m s -> (s -> m b) -> Parser m a b
Parser SeqParseState s (b -> c) s
-> x -> m (Step (SeqParseState s (b -> c) s) c)
step m (SeqParseState s (b -> c) s)
forall f sr. m (SeqParseState s f sr)
initial SeqParseState s (b -> c) s -> m c
extract

    where

    initial :: m (SeqParseState s f sr)
initial = s -> SeqParseState s f sr
forall sl f sr. sl -> SeqParseState sl f sr
SeqParseL (s -> SeqParseState s f sr) -> m s -> m (SeqParseState s f sr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m s
initialL

    -- Note: For the composed parse to terminate, the left parser has to be
    -- a terminating parser returning a Stop at some point.
    step :: SeqParseState s (b -> c) s
-> x -> m (Step (SeqParseState s (b -> c) s) c)
step (SeqParseL s
st) x
a = do
        Step s a
r <- s -> x -> m (Step s a)
stepL s
st x
a
        case Step s a
r of
            -- Note: this leads to buffering even if we are not in an
            -- Alternative composition.
            Yield Int
_ s
s -> Step (SeqParseState s (b -> c) s) c
-> m (Step (SeqParseState s (b -> c) s) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (SeqParseState s (b -> c) s) c
 -> m (Step (SeqParseState s (b -> c) s) c))
-> Step (SeqParseState s (b -> c) s) c
-> m (Step (SeqParseState s (b -> c) s) c)
forall a b. (a -> b) -> a -> b
$ Int
-> SeqParseState s (b -> c) s
-> Step (SeqParseState s (b -> c) s) c
forall s b. Int -> s -> Step s b
Skip Int
0 (s -> SeqParseState s (b -> c) s
forall sl f sr. sl -> SeqParseState sl f sr
SeqParseL s
s)
            Skip Int
n s
s -> Step (SeqParseState s (b -> c) s) c
-> m (Step (SeqParseState s (b -> c) s) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (SeqParseState s (b -> c) s) c
 -> m (Step (SeqParseState s (b -> c) s) c))
-> Step (SeqParseState s (b -> c) s) c
-> m (Step (SeqParseState s (b -> c) s) c)
forall a b. (a -> b) -> a -> b
$ Int
-> SeqParseState s (b -> c) s
-> Step (SeqParseState s (b -> c) s) c
forall s b. Int -> s -> Step s b
Skip Int
n (s -> SeqParseState s (b -> c) s
forall sl f sr. sl -> SeqParseState sl f sr
SeqParseL s
s)
            Stop Int
n a
b -> Int
-> SeqParseState s (b -> c) s
-> Step (SeqParseState s (b -> c) s) c
forall s b. Int -> s -> Step s b
Skip Int
n (SeqParseState s (b -> c) s -> Step (SeqParseState s (b -> c) s) c)
-> m (SeqParseState s (b -> c) s)
-> m (Step (SeqParseState s (b -> c) s) c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((b -> c) -> s -> SeqParseState s (b -> c) s
forall sl f sr. f -> sr -> SeqParseState sl f sr
SeqParseR (a -> b -> c
func a
b) (s -> SeqParseState s (b -> c) s)
-> m s -> m (SeqParseState s (b -> c) s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m s
initialR)
            Error String
err -> Step (SeqParseState s (b -> c) s) c
-> m (Step (SeqParseState s (b -> c) s) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (SeqParseState s (b -> c) s) c
 -> m (Step (SeqParseState s (b -> c) s) c))
-> Step (SeqParseState s (b -> c) s) c
-> m (Step (SeqParseState s (b -> c) s) c)
forall a b. (a -> b) -> a -> b
$ String -> Step (SeqParseState s (b -> c) s) c
forall s b. String -> Step s b
Error String
err

    step (SeqParseR b -> c
f s
st) x
a = do
        Step s b
r <- s -> x -> m (Step s b)
stepR s
st x
a
        Step (SeqParseState s (b -> c) s) c
-> m (Step (SeqParseState s (b -> c) s) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (SeqParseState s (b -> c) s) c
 -> m (Step (SeqParseState s (b -> c) s) c))
-> Step (SeqParseState s (b -> c) s) c
-> m (Step (SeqParseState s (b -> c) s) c)
forall a b. (a -> b) -> a -> b
$ case Step s b
r of
            Yield Int
n s
s -> Int
-> SeqParseState s (b -> c) s
-> Step (SeqParseState s (b -> c) s) c
forall s b. Int -> s -> Step s b
Yield Int
n ((b -> c) -> s -> SeqParseState s (b -> c) s
forall sl f sr. f -> sr -> SeqParseState sl f sr
SeqParseR b -> c
f s
s)
            Skip Int
n s
s -> Int
-> SeqParseState s (b -> c) s
-> Step (SeqParseState s (b -> c) s) c
forall s b. Int -> s -> Step s b
Skip Int
n ((b -> c) -> s -> SeqParseState s (b -> c) s
forall sl f sr. f -> sr -> SeqParseState sl f sr
SeqParseR b -> c
f s
s)
            Stop Int
n b
b -> Int -> c -> Step (SeqParseState s (b -> c) s) c
forall s b. Int -> b -> Step s b
Stop Int
n (b -> c
f b
b)
            Error String
err -> String -> Step (SeqParseState s (b -> c) s) c
forall s b. String -> Step s b
Error String
err

    extract :: SeqParseState s (b -> c) s -> m c
extract (SeqParseR b -> c
f s
sR) = (b -> c) -> m b -> m c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> c
f (s -> m b
extractR s
sR)
    extract (SeqParseL s
sL) = do
        a
rL <- s -> m a
extractL s
sL
        s
sR <- m s
initialR
        b
rR <- s -> m b
extractR s
sR
        c -> m c
forall (m :: * -> *) a. Monad m => a -> m a
return (c -> m c) -> c -> m c
forall a b. (a -> b) -> a -> b
$ a -> b -> c
func a
rL b
rR

-- | 'Applicative' form of 'splitWith'.
instance Monad m => Applicative (Parser m a) where
    {-# INLINE pure #-}
    pure :: a -> Parser m a a
pure = a -> Parser m a a
forall (m :: * -> *) b a. Monad m => b -> Parser m a b
yield

    {-# INLINE (<*>) #-}
    <*> :: Parser m a (a -> b) -> Parser m a a -> Parser m a b
(<*>) = ((a -> b) -> a -> b)
-> Parser m a (a -> b) -> Parser m a a -> Parser m a b
forall (m :: * -> *) a b c x.
Monad m =>
(a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c
splitWith (a -> b) -> a -> b
forall a. a -> a
id

-------------------------------------------------------------------------------
-- Sequential Alternative
-------------------------------------------------------------------------------

{-# ANN type AltParseState Fuse #-}
data AltParseState sl sr = AltParseL Int sl | AltParseR sr

-- Note: this implementation of alt is fast because of stream fusion but has
-- quadratic time complexity, because each composition adds a new branch that
-- each subsequent alternative's input element has to go through, therefore, it
-- cannot scale to a large number of compositions
--
-- | Sequential alternative. Apply the input to the first parser and return the
-- result if the parser succeeds. If the first parser fails then backtrack and
-- apply the same input to the second parser and return the result.
--
-- Note: This implementation is not lazy in the second argument. The following
-- will fail:
--
-- >>> S.parse (PR.satisfy (> 0) `PR.alt` undefined) $ S.fromList [1..10]
--
-- /Internal/
--
{-# INLINE alt #-}
alt :: Monad m => Parser m x a -> Parser m x a -> Parser m x a
alt :: Parser m x a -> Parser m x a -> Parser m x a
alt (Parser s -> x -> m (Step s a)
stepL m s
initialL s -> m a
extractL) (Parser s -> x -> m (Step s a)
stepR m s
initialR s -> m a
extractR) =
    (AltParseState s s -> x -> m (Step (AltParseState s s) a))
-> m (AltParseState s s)
-> (AltParseState s s -> m a)
-> Parser m x a
forall (m :: * -> *) a b s.
(s -> a -> m (Step s b)) -> m s -> (s -> m b) -> Parser m a b
Parser AltParseState s s -> x -> m (Step (AltParseState s s) a)
step m (AltParseState s s)
forall sr. m (AltParseState s sr)
initial AltParseState s s -> m a
extract

    where

    initial :: m (AltParseState s sr)
initial = Int -> s -> AltParseState s sr
forall sl sr. Int -> sl -> AltParseState sl sr
AltParseL Int
0 (s -> AltParseState s sr) -> m s -> m (AltParseState s sr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m s
initialL

    -- Once a parser yields at least one value it cannot fail.  This
    -- restriction helps us make backtracking more efficient, as we do not need
    -- to keep the consumed items buffered after a yield. Note that we do not
    -- enforce this and if a misbehaving parser does not honor this then we can
    -- get unexpected results.
    step :: AltParseState s s -> x -> m (Step (AltParseState s s) a)
step (AltParseL Int
cnt s
st) x
a = do
        Step s a
r <- s -> x -> m (Step s a)
stepL s
st x
a
        case Step s a
r of
            Yield Int
n s
s -> Step (AltParseState s s) a -> m (Step (AltParseState s s) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (AltParseState s s) a -> m (Step (AltParseState s s) a))
-> Step (AltParseState s s) a -> m (Step (AltParseState s s) a)
forall a b. (a -> b) -> a -> b
$ Int -> AltParseState s s -> Step (AltParseState s s) a
forall s b. Int -> s -> Step s b
Yield Int
n (Int -> s -> AltParseState s s
forall sl sr. Int -> sl -> AltParseState sl sr
AltParseL Int
0 s
s)
            Skip Int
n s
s -> do
                Bool -> m () -> m ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0) (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                Step (AltParseState s s) a -> m (Step (AltParseState s s) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (AltParseState s s) a -> m (Step (AltParseState s s) a))
-> Step (AltParseState s s) a -> m (Step (AltParseState s s) a)
forall a b. (a -> b) -> a -> b
$ Int -> AltParseState s s -> Step (AltParseState s s) a
forall s b. Int -> s -> Step s b
Skip Int
n (Int -> s -> AltParseState s s
forall sl sr. Int -> sl -> AltParseState sl sr
AltParseL (Int
cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) s
s)
            Stop Int
n a
b -> Step (AltParseState s s) a -> m (Step (AltParseState s s) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (AltParseState s s) a -> m (Step (AltParseState s s) a))
-> Step (AltParseState s s) a -> m (Step (AltParseState s s) a)
forall a b. (a -> b) -> a -> b
$ Int -> a -> Step (AltParseState s s) a
forall s b. Int -> b -> Step s b
Stop Int
n a
b
            Error String
_ -> do
                s
rR <- m s
initialR
                Step (AltParseState s s) a -> m (Step (AltParseState s s) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (AltParseState s s) a -> m (Step (AltParseState s s) a))
-> Step (AltParseState s s) a -> m (Step (AltParseState s s) a)
forall a b. (a -> b) -> a -> b
$ Int -> AltParseState s s -> Step (AltParseState s s) a
forall s b. Int -> s -> Step s b
Skip (Int
cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (s -> AltParseState s s
forall sl sr. sr -> AltParseState sl sr
AltParseR s
rR)

    step (AltParseR s
st) x
a = do
        Step s a
r <- s -> x -> m (Step s a)
stepR s
st x
a
        Step (AltParseState s s) a -> m (Step (AltParseState s s) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (AltParseState s s) a -> m (Step (AltParseState s s) a))
-> Step (AltParseState s s) a -> m (Step (AltParseState s s) a)
forall a b. (a -> b) -> a -> b
$ case Step s a
r of
            Yield Int
n s
s -> Int -> AltParseState s s -> Step (AltParseState s s) a
forall s b. Int -> s -> Step s b
Yield Int
n (s -> AltParseState s s
forall sl sr. sr -> AltParseState sl sr
AltParseR s
s)
            Skip Int
n s
s -> Int -> AltParseState s s -> Step (AltParseState s s) a
forall s b. Int -> s -> Step s b
Skip Int
n (s -> AltParseState s s
forall sl sr. sr -> AltParseState sl sr
AltParseR s
s)
            Stop Int
n a
b -> Int -> a -> Step (AltParseState s s) a
forall s b. Int -> b -> Step s b
Stop Int
n a
b
            Error String
err -> String -> Step (AltParseState s s) a
forall s b. String -> Step s b
Error String
err

    extract :: AltParseState s s -> m a
extract (AltParseR s
sR) = s -> m a
extractR s
sR
    extract (AltParseL Int
_ s
sL) = s -> m a
extractL s
sL

-- | See documentation of 'Streamly.Internal.Data.Parser.many'.
--
-- /Internal/
--
{-# INLINE splitMany #-}
splitMany :: MonadCatch m => Fold m b c -> Parser m a b -> Parser m a c
splitMany :: Fold m b c -> Parser m a b -> Parser m a c
splitMany (Fold s -> b -> m s
fstep m s
finitial s -> m c
fextract) (Parser s -> a -> m (Step s b)
step1 m s
initial1 s -> m b
extract1) =
    (Tuple3' s Int s -> a -> m (Step (Tuple3' s Int s) c))
-> m (Tuple3' s Int s) -> (Tuple3' s Int s -> m c) -> Parser m a c
forall (m :: * -> *) a b s.
(s -> a -> m (Step s b)) -> m s -> (s -> m b) -> Parser m a b
Parser Tuple3' s Int s -> a -> m (Step (Tuple3' s Int s) c)
step m (Tuple3' s Int s)
initial Tuple3' s Int s -> m c
forall b. Tuple3' s b s -> m c
extract

    where

    initial :: m (Tuple3' s Int s)
initial = do
        s
ps <- m s
initial1 -- parse state
        s
fs <- m s
finitial -- fold state
        Tuple3' s Int s -> m (Tuple3' s Int s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (s -> Int -> s -> Tuple3' s Int s
forall a b c. a -> b -> c -> Tuple3' a b c
Tuple3' s
ps Int
0 s
fs)

    {-# INLINE step #-}
    step :: Tuple3' s Int s -> a -> m (Step (Tuple3' s Int s) c)
step (Tuple3' s
st Int
cnt s
fs) a
a = do
        Step s b
r <- s -> a -> m (Step s b)
step1 s
st a
a
        let cnt1 :: Int
cnt1 = Int
cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        case Step s b
r of
            Yield Int
_ s
s -> Step (Tuple3' s Int s) c -> m (Step (Tuple3' s Int s) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (Tuple3' s Int s) c -> m (Step (Tuple3' s Int s) c))
-> Step (Tuple3' s Int s) c -> m (Step (Tuple3' s Int s) c)
forall a b. (a -> b) -> a -> b
$ Int -> Tuple3' s Int s -> Step (Tuple3' s Int s) c
forall s b. Int -> s -> Step s b
Skip Int
0 (s -> Int -> s -> Tuple3' s Int s
forall a b c. a -> b -> c -> Tuple3' a b c
Tuple3' s
s Int
cnt1 s
fs)
            Skip Int
n s
s -> do
                Bool -> m () -> m ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
cnt1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0) (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                Step (Tuple3' s Int s) c -> m (Step (Tuple3' s Int s) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (Tuple3' s Int s) c -> m (Step (Tuple3' s Int s) c))
-> Step (Tuple3' s Int s) c -> m (Step (Tuple3' s Int s) c)
forall a b. (a -> b) -> a -> b
$ Int -> Tuple3' s Int s -> Step (Tuple3' s Int s) c
forall s b. Int -> s -> Step s b
Skip Int
n (s -> Int -> s -> Tuple3' s Int s
forall a b c. a -> b -> c -> Tuple3' a b c
Tuple3' s
s (Int
cnt1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) s
fs)
            Stop Int
n b
b -> do
                s
s <- m s
initial1
                s
fs1 <- s -> b -> m s
fstep s
fs b
b
                -- XXX we need to yield and backtrack here
                Step (Tuple3' s Int s) c -> m (Step (Tuple3' s Int s) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (Tuple3' s Int s) c -> m (Step (Tuple3' s Int s) c))
-> Step (Tuple3' s Int s) c -> m (Step (Tuple3' s Int s) c)
forall a b. (a -> b) -> a -> b
$ Int -> Tuple3' s Int s -> Step (Tuple3' s Int s) c
forall s b. Int -> s -> Step s b
Skip Int
n (s -> Int -> s -> Tuple3' s Int s
forall a b c. a -> b -> c -> Tuple3' a b c
Tuple3' s
s Int
0 s
fs1)
            Error String
_ -> do
                c
xs <- s -> m c
fextract s
fs
                Step (Tuple3' s Int s) c -> m (Step (Tuple3' s Int s) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (Tuple3' s Int s) c -> m (Step (Tuple3' s Int s) c))
-> Step (Tuple3' s Int s) c -> m (Step (Tuple3' s Int s) c)
forall a b. (a -> b) -> a -> b
$ Int -> c -> Step (Tuple3' s Int s) c
forall s b. Int -> b -> Step s b
Stop Int
cnt1 c
xs

    -- XXX The "try" may impact performance if this parser is used as a scan
    extract :: Tuple3' s b s -> m c
extract (Tuple3' s
s b
_ s
fs) = do
        Either ParseError b
r <- m b -> m (Either ParseError b)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (m b -> m (Either ParseError b)) -> m b -> m (Either ParseError b)
forall a b. (a -> b) -> a -> b
$ s -> m b
extract1 s
s
        case Either ParseError b
r of
            Left (ParseError
_ :: ParseError) -> s -> m c
fextract s
fs
            Right b
b -> s -> b -> m s
fstep s
fs b
b m s -> (s -> m c) -> m c
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> m c
fextract

-- | See documentation of 'Streamly.Internal.Data.Parser.some'.
--
-- /Internal/
--
{-# INLINE splitSome #-}
splitSome :: MonadCatch m => Fold m b c -> Parser m a b -> Parser m a c
splitSome :: Fold m b c -> Parser m a b -> Parser m a c
splitSome (Fold s -> b -> m s
fstep m s
finitial s -> m c
fextract) (Parser s -> a -> m (Step s b)
step1 m s
initial1 s -> m b
extract1) =
    (Tuple3' s Int (Either s s)
 -> a -> m (Step (Tuple3' s Int (Either s s)) c))
-> m (Tuple3' s Int (Either s s))
-> (Tuple3' s Int (Either s s) -> m c)
-> Parser m a c
forall (m :: * -> *) a b s.
(s -> a -> m (Step s b)) -> m s -> (s -> m b) -> Parser m a b
Parser Tuple3' s Int (Either s s)
-> a -> m (Step (Tuple3' s Int (Either s s)) c)
step m (Tuple3' s Int (Either s s))
forall b. m (Tuple3' s Int (Either s b))
initial Tuple3' s Int (Either s s) -> m c
forall b. Tuple3' s b (Either s s) -> m c
extract

    where

    initial :: m (Tuple3' s Int (Either s b))
initial = do
        s
ps <- m s
initial1 -- parse state
        s
fs <- m s
finitial -- fold state
        Tuple3' s Int (Either s b) -> m (Tuple3' s Int (Either s b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (s -> Int -> Either s b -> Tuple3' s Int (Either s b)
forall a b c. a -> b -> c -> Tuple3' a b c
Tuple3' s
ps Int
0 (s -> Either s b
forall a b. a -> Either a b
Left s
fs))

    {-# INLINE step #-}
    step :: Tuple3' s Int (Either s s)
-> a -> m (Step (Tuple3' s Int (Either s s)) c)
step (Tuple3' s
st Int
_ (Left s
fs)) a
a = do
        Step s b
r <- s -> a -> m (Step s b)
step1 s
st a
a
        case Step s b
r of
            Yield Int
_ s
s -> Step (Tuple3' s Int (Either s s)) c
-> m (Step (Tuple3' s Int (Either s s)) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (Tuple3' s Int (Either s s)) c
 -> m (Step (Tuple3' s Int (Either s s)) c))
-> Step (Tuple3' s Int (Either s s)) c
-> m (Step (Tuple3' s Int (Either s s)) c)
forall a b. (a -> b) -> a -> b
$ Int
-> Tuple3' s Int (Either s s)
-> Step (Tuple3' s Int (Either s s)) c
forall s b. Int -> s -> Step s b
Skip Int
0 (s -> Int -> Either s s -> Tuple3' s Int (Either s s)
forall a b c. a -> b -> c -> Tuple3' a b c
Tuple3' s
s Int
forall a. (?callStack::CallStack) => a
undefined (s -> Either s s
forall a b. a -> Either a b
Left s
fs))
            Skip  Int
n s
s -> Step (Tuple3' s Int (Either s s)) c
-> m (Step (Tuple3' s Int (Either s s)) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (Tuple3' s Int (Either s s)) c
 -> m (Step (Tuple3' s Int (Either s s)) c))
-> Step (Tuple3' s Int (Either s s)) c
-> m (Step (Tuple3' s Int (Either s s)) c)
forall a b. (a -> b) -> a -> b
$ Int
-> Tuple3' s Int (Either s s)
-> Step (Tuple3' s Int (Either s s)) c
forall s b. Int -> s -> Step s b
Skip Int
n (s -> Int -> Either s s -> Tuple3' s Int (Either s s)
forall a b c. a -> b -> c -> Tuple3' a b c
Tuple3' s
s Int
forall a. (?callStack::CallStack) => a
undefined (s -> Either s s
forall a b. a -> Either a b
Left s
fs))
            Stop Int
n b
b -> do
                s
s <- m s
initial1
                s
fs1 <- s -> b -> m s
fstep s
fs b
b
                -- XXX this is also a yield point, we will never fail beyond
                -- this point. If we do not yield then if an error occurs after
                -- this then we will backtrack to the previous yield point
                -- instead of this point which is wrong.
                --
                -- so we need a yield with backtrack
                Step (Tuple3' s Int (Either s s)) c
-> m (Step (Tuple3' s Int (Either s s)) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (Tuple3' s Int (Either s s)) c
 -> m (Step (Tuple3' s Int (Either s s)) c))
-> Step (Tuple3' s Int (Either s s)) c
-> m (Step (Tuple3' s Int (Either s s)) c)
forall a b. (a -> b) -> a -> b
$ Int
-> Tuple3' s Int (Either s s)
-> Step (Tuple3' s Int (Either s s)) c
forall s b. Int -> s -> Step s b
Skip Int
n (s -> Int -> Either s s -> Tuple3' s Int (Either s s)
forall a b c. a -> b -> c -> Tuple3' a b c
Tuple3' s
s Int
0 (s -> Either s s
forall a b. b -> Either a b
Right s
fs1))
            Error String
err -> Step (Tuple3' s Int (Either s s)) c
-> m (Step (Tuple3' s Int (Either s s)) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (Tuple3' s Int (Either s s)) c
 -> m (Step (Tuple3' s Int (Either s s)) c))
-> Step (Tuple3' s Int (Either s s)) c
-> m (Step (Tuple3' s Int (Either s s)) c)
forall a b. (a -> b) -> a -> b
$ String -> Step (Tuple3' s Int (Either s s)) c
forall s b. String -> Step s b
Error String
err
    step (Tuple3' s
st Int
cnt (Right s
fs)) a
a = do
        Step s b
r <- s -> a -> m (Step s b)
step1 s
st a
a
        let cnt1 :: Int
cnt1 = Int
cnt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
        case Step s b
r of
            Yield Int
_ s
s -> Step (Tuple3' s Int (Either s s)) c
-> m (Step (Tuple3' s Int (Either s s)) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (Tuple3' s Int (Either s s)) c
 -> m (Step (Tuple3' s Int (Either s s)) c))
-> Step (Tuple3' s Int (Either s s)) c
-> m (Step (Tuple3' s Int (Either s s)) c)
forall a b. (a -> b) -> a -> b
$ Int
-> Tuple3' s Int (Either s s)
-> Step (Tuple3' s Int (Either s s)) c
forall s b. Int -> s -> Step s b
Yield Int
0 (s -> Int -> Either s s -> Tuple3' s Int (Either s s)
forall a b c. a -> b -> c -> Tuple3' a b c
Tuple3' s
s Int
cnt1 (s -> Either s s
forall a b. b -> Either a b
Right s
fs))
            Skip Int
n s
s -> do
                Bool -> m () -> m ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
cnt1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0) (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                Step (Tuple3' s Int (Either s s)) c
-> m (Step (Tuple3' s Int (Either s s)) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (Tuple3' s Int (Either s s)) c
 -> m (Step (Tuple3' s Int (Either s s)) c))
-> Step (Tuple3' s Int (Either s s)) c
-> m (Step (Tuple3' s Int (Either s s)) c)
forall a b. (a -> b) -> a -> b
$ Int
-> Tuple3' s Int (Either s s)
-> Step (Tuple3' s Int (Either s s)) c
forall s b. Int -> s -> Step s b
Skip Int
n (s -> Int -> Either s s -> Tuple3' s Int (Either s s)
forall a b c. a -> b -> c -> Tuple3' a b c
Tuple3' s
s (Int
cnt1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) (s -> Either s s
forall a b. b -> Either a b
Right s
fs))
            Stop Int
n b
b -> do
                s
s <- m s
initial1
                s
fs1 <- s -> b -> m s
fstep s
fs b
b
                -- XXX we need to yield here but also backtrack
                Step (Tuple3' s Int (Either s s)) c
-> m (Step (Tuple3' s Int (Either s s)) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (Tuple3' s Int (Either s s)) c
 -> m (Step (Tuple3' s Int (Either s s)) c))
-> Step (Tuple3' s Int (Either s s)) c
-> m (Step (Tuple3' s Int (Either s s)) c)
forall a b. (a -> b) -> a -> b
$ Int
-> Tuple3' s Int (Either s s)
-> Step (Tuple3' s Int (Either s s)) c
forall s b. Int -> s -> Step s b
Skip Int
n (s -> Int -> Either s s -> Tuple3' s Int (Either s s)
forall a b c. a -> b -> c -> Tuple3' a b c
Tuple3' s
s Int
0 (s -> Either s s
forall a b. b -> Either a b
Right s
fs1))
            Error String
_ -> Int -> c -> Step (Tuple3' s Int (Either s s)) c
forall s b. Int -> b -> Step s b
Stop Int
cnt1 (c -> Step (Tuple3' s Int (Either s s)) c)
-> m c -> m (Step (Tuple3' s Int (Either s s)) c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> s -> m c
fextract s
fs

    -- XXX The "try" may impact performance if this parser is used as a scan
    extract :: Tuple3' s b (Either s s) -> m c
extract (Tuple3' s
s b
_ (Left s
fs)) = s -> m b
extract1 s
s m b -> (b -> m s) -> m s
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> b -> m s
fstep s
fs m s -> (s -> m c) -> m c
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> m c
fextract
    extract (Tuple3' s
s b
_ (Right s
fs)) = do
        Either ParseError b
r <- m b -> m (Either ParseError b)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (m b -> m (Either ParseError b)) -> m b -> m (Either ParseError b)
forall a b. (a -> b) -> a -> b
$ s -> m b
extract1 s
s
        case Either ParseError b
r of
            Left (ParseError
_ :: ParseError) -> s -> m c
fextract s
fs
            Right b
b -> s -> b -> m s
fstep s
fs b
b m s -> (s -> m c) -> m c
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> m c
fextract

-- This is the dual of "nil".
--
-- | A parser that always fails with an error message without consuming
-- any input.
--
-- /Internal/
--
{-# INLINE die #-}
die :: MonadThrow m => String -> Parser m a b
die :: String -> Parser m a b
die String
err =
    (() -> a -> m (Step () b)) -> m () -> (() -> m b) -> Parser m a b
forall (m :: * -> *) a b s.
(s -> a -> m (Step s b)) -> m s -> (s -> m b) -> Parser m a b
Parser (\()
_ a
_ -> Step () b -> m (Step () b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Step () b -> m (Step () b)) -> Step () b -> m (Step () b)
forall a b. (a -> b) -> a -> b
$ String -> Step () b
forall s b. String -> Step s b
Error String
err)      -- step
           (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())                       -- initial
           (\()
_ -> ParseError -> m b
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ParseError -> m b) -> ParseError -> m b
forall a b. (a -> b) -> a -> b
$ String -> ParseError
ParseError String
err) -- extract

-- This is the dual of "nilM".
--
-- | A parser that always fails with an effectful error message and without
-- consuming any input.
--
-- /Internal/
--
{-# INLINE dieM #-}
dieM :: MonadThrow m => m String -> Parser m a b
dieM :: m String -> Parser m a b
dieM m String
err =
    (() -> a -> m (Step () b)) -> m () -> (() -> m b) -> Parser m a b
forall (m :: * -> *) a b s.
(s -> a -> m (Step s b)) -> m s -> (s -> m b) -> Parser m a b
Parser (\()
_ a
_ -> String -> Step () b
forall s b. String -> Step s b
Error (String -> Step () b) -> m String -> m (Step () b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m String
err)         -- step
           (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())                       -- initial
           (\()
_ -> m String
err m String -> (String -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ParseError -> m b
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ParseError -> m b) -> (String -> ParseError) -> String -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParseError
ParseError) -- extract

-- Note: The default implementations of "some" and "many" loop infinitely
-- because of the strict pattern match on both the arguments in applicative and
-- alternative. With the direct style parser type we cannot use the mutually
-- recursive definitions of "some" and "many".
--
-- Note: With the direct style parser type, the list in "some" and "many" is
-- accumulated strictly, it cannot be consumed lazily.

-- | 'Alternative' instance using 'alt'.
--
-- Note: The implementation of '<|>' is not lazy in the second
-- argument. The following code will fail:
--
-- >>> S.parse (PR.satisfy (> 0) <|> undefined) $ S.fromList [1..10]
--
instance MonadCatch m => Alternative (Parser m a) where
    {-# INLINE empty #-}
    empty :: Parser m a a
empty = String -> Parser m a a
forall (m :: * -> *) a b. MonadThrow m => String -> Parser m a b
die String
"empty"

    {-# INLINE (<|>) #-}
    <|> :: Parser m a a -> Parser m a a -> Parser m a a
(<|>) = Parser m a a -> Parser m a a -> Parser m a a
forall (m :: * -> *) x a.
Monad m =>
Parser m x a -> Parser m x a -> Parser m x a
alt

    {-# INLINE many #-}
    many :: Parser m a a -> Parser m a [a]
many = Fold m a [a] -> Parser m a a -> Parser m a [a]
forall (m :: * -> *) b c a.
MonadCatch m =>
Fold m b c -> Parser m a b -> Parser m a c
splitMany Fold m a [a]
forall (m :: * -> *) a. Monad m => Fold m a [a]
toList

    {-# INLINE some #-}
    some :: Parser m a a -> Parser m a [a]
some = Fold m a [a] -> Parser m a a -> Parser m a [a]
forall (m :: * -> *) b c a.
MonadCatch m =>
Fold m b c -> Parser m a b -> Parser m a c
splitSome Fold m a [a]
forall (m :: * -> *) a. Monad m => Fold m a [a]
toList

{-# ANN type ConcatParseState Fuse #-}
data ConcatParseState sl p = ConcatParseL sl | ConcatParseR p

-- Note: The monad instance has quadratic performance complexity. It works fine
-- for small number of compositions but for a scalable implementation we need a
-- CPS version.

-- | Monad composition can be used for lookbehind parsers, we can make the
-- future parses depend on the previously parsed values.
--
-- If we have to parse "a9" or "9a" but not "99" or "aa" we can use the
-- following parser:
--
-- @
-- backtracking :: MonadCatch m => PR.Parser m Char String
-- backtracking =
--     sequence [PR.satisfy isDigit, PR.satisfy isAlpha]
--     '<|>'
--     sequence [PR.satisfy isAlpha, PR.satisfy isDigit]
-- @
--
-- We know that if the first parse resulted in a digit at the first place then
-- the second parse is going to fail.  However, we waste that information and
-- parse the first character again in the second parse only to know that it is
-- not an alphabetic char.  By using lookbehind in a 'Monad' composition we can
-- avoid redundant work:
--
-- @
-- data DigitOrAlpha = Digit Char | Alpha Char
--
-- lookbehind :: MonadCatch m => PR.Parser m Char String
-- lookbehind = do
--     x1 \<-    Digit '<$>' PR.satisfy isDigit
--          '<|>' Alpha '<$>' PR.satisfy isAlpha
--
--     -- Note: the parse depends on what we parsed already
--     x2 <- case x1 of
--         Digit _ -> PR.satisfy isAlpha
--         Alpha _ -> PR.satisfy isDigit
--
--     return $ case x1 of
--         Digit x -> [x,x2]
--         Alpha x -> [x,x2]
-- @
--
instance Monad m => Monad (Parser m a) where
    {-# INLINE return #-}
    return :: a -> Parser m a a
return = a -> Parser m a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

    -- (>>=) :: Parser m a b -> (b -> Parser m a c) -> Parser m a c
    {-# INLINE (>>=) #-}
    (Parser s -> a -> m (Step s a)
stepL m s
initialL s -> m a
extractL) >>= :: Parser m a a -> (a -> Parser m a b) -> Parser m a b
>>= a -> Parser m a b
func = (ConcatParseState s (Parser m a b)
 -> a -> m (Step (ConcatParseState s (Parser m a b)) b))
-> m (ConcatParseState s (Parser m a b))
-> (ConcatParseState s (Parser m a b) -> m b)
-> Parser m a b
forall (m :: * -> *) a b s.
(s -> a -> m (Step s b)) -> m s -> (s -> m b) -> Parser m a b
Parser ConcatParseState s (Parser m a b)
-> a -> m (Step (ConcatParseState s (Parser m a b)) b)
step m (ConcatParseState s (Parser m a b))
forall p. m (ConcatParseState s p)
initial ConcatParseState s (Parser m a b) -> m b
forall a. ConcatParseState s (Parser m a b) -> m b
extract

        where

        initial :: m (ConcatParseState s p)
initial = s -> ConcatParseState s p
forall sl p. sl -> ConcatParseState sl p
ConcatParseL (s -> ConcatParseState s p) -> m s -> m (ConcatParseState s p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m s
initialL

        step :: ConcatParseState s (Parser m a b)
-> a -> m (Step (ConcatParseState s (Parser m a b)) b)
step (ConcatParseL s
st) a
a = do
            Step s a
r <- s -> a -> m (Step s a)
stepL s
st a
a
            Step (ConcatParseState s (Parser m a b)) b
-> m (Step (ConcatParseState s (Parser m a b)) b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (ConcatParseState s (Parser m a b)) b
 -> m (Step (ConcatParseState s (Parser m a b)) b))
-> Step (ConcatParseState s (Parser m a b)) b
-> m (Step (ConcatParseState s (Parser m a b)) b)
forall a b. (a -> b) -> a -> b
$ case Step s a
r of
                Yield Int
_ s
s -> Int
-> ConcatParseState s (Parser m a b)
-> Step (ConcatParseState s (Parser m a b)) b
forall s b. Int -> s -> Step s b
Skip Int
0 (s -> ConcatParseState s (Parser m a b)
forall sl p. sl -> ConcatParseState sl p
ConcatParseL s
s)
                Skip Int
n s
s -> Int
-> ConcatParseState s (Parser m a b)
-> Step (ConcatParseState s (Parser m a b)) b
forall s b. Int -> s -> Step s b
Skip Int
n (s -> ConcatParseState s (Parser m a b)
forall sl p. sl -> ConcatParseState sl p
ConcatParseL s
s)
                Stop Int
n a
b -> Int
-> ConcatParseState s (Parser m a b)
-> Step (ConcatParseState s (Parser m a b)) b
forall s b. Int -> s -> Step s b
Skip Int
n (Parser m a b -> ConcatParseState s (Parser m a b)
forall sl p. p -> ConcatParseState sl p
ConcatParseR (a -> Parser m a b
func a
b))
                Error String
err -> String -> Step (ConcatParseState s (Parser m a b)) b
forall s b. String -> Step s b
Error String
err

        step (ConcatParseR (Parser s -> a -> m (Step s b)
stepR m s
initialR s -> m b
extractR)) a
a = do
            s
st <- m s
initialR
            Step s b
r <- s -> a -> m (Step s b)
stepR s
st a
a
            Step (ConcatParseState s (Parser m a b)) b
-> m (Step (ConcatParseState s (Parser m a b)) b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (ConcatParseState s (Parser m a b)) b
 -> m (Step (ConcatParseState s (Parser m a b)) b))
-> Step (ConcatParseState s (Parser m a b)) b
-> m (Step (ConcatParseState s (Parser m a b)) b)
forall a b. (a -> b) -> a -> b
$ case Step s b
r of
                Yield Int
n s
s ->
                    Int
-> ConcatParseState s (Parser m a b)
-> Step (ConcatParseState s (Parser m a b)) b
forall s b. Int -> s -> Step s b
Yield Int
n (Parser m a b -> ConcatParseState s (Parser m a b)
forall sl p. p -> ConcatParseState sl p
ConcatParseR ((s -> a -> m (Step s b)) -> m s -> (s -> m b) -> Parser m a b
forall (m :: * -> *) a b s.
(s -> a -> m (Step s b)) -> m s -> (s -> m b) -> Parser m a b
Parser s -> a -> m (Step s b)
stepR (s -> m s
forall (m :: * -> *) a. Monad m => a -> m a
return s
s) s -> m b
extractR))
                Skip Int
n s
s ->
                    Int
-> ConcatParseState s (Parser m a b)
-> Step (ConcatParseState s (Parser m a b)) b
forall s b. Int -> s -> Step s b
Skip Int
n (Parser m a b -> ConcatParseState s (Parser m a b)
forall sl p. p -> ConcatParseState sl p
ConcatParseR ((s -> a -> m (Step s b)) -> m s -> (s -> m b) -> Parser m a b
forall (m :: * -> *) a b s.
(s -> a -> m (Step s b)) -> m s -> (s -> m b) -> Parser m a b
Parser s -> a -> m (Step s b)
stepR (s -> m s
forall (m :: * -> *) a. Monad m => a -> m a
return s
s) s -> m b
extractR))
                Stop Int
n b
b -> Int -> b -> Step (ConcatParseState s (Parser m a b)) b
forall s b. Int -> b -> Step s b
Stop Int
n b
b
                Error String
err -> String -> Step (ConcatParseState s (Parser m a b)) b
forall s b. String -> Step s b
Error String
err

        extract :: ConcatParseState s (Parser m a b) -> m b
extract (ConcatParseR (Parser s -> a -> m (Step s b)
_ m s
initialR s -> m b
extractR)) =
            m s
initialR m s -> (s -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> m b
extractR

        extract (ConcatParseL s
sL) = s -> m a
extractL s
sL m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parser m a b -> m b
forall (m :: * -> *) a b. Monad m => Parser m a b -> m b
f (Parser m a b -> m b) -> (a -> Parser m a b) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Parser m a b
func

            where

            f :: Parser m a b -> m b
f (Parser s -> a -> m (Step s b)
_ m s
initialR s -> m b
extractR) = m s
initialR m s -> (s -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> m b
extractR

-- | 'mzero' is same as 'empty', it aborts the parser. 'mplus' is same as
-- '<|>', it selects the first succeeding parser.
--
-- /Internal/
--
instance MonadCatch m => MonadPlus (Parser m a) where
    {-# INLINE mzero #-}
    mzero :: Parser m a a
mzero = String -> Parser m a a
forall (m :: * -> *) a b. MonadThrow m => String -> Parser m a b
die String
"mzero"

    {-# INLINE mplus #-}
    mplus :: Parser m a a -> Parser m a a -> Parser m a a
mplus = Parser m a a -> Parser m a a -> Parser m a a
forall (m :: * -> *) x a.
Monad m =>
Parser m x a -> Parser m x a -> Parser m x a
alt