{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}

#if __GLASGOW_HASKELL__ >= 800
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
#endif

#include "inline.hs"

-- |
-- Module      : Streamly.Internal.Data.Parser.Tee
-- Copyright   : (c) 2020 Composewell Technologies
-- License     : BSD3
-- Maintainer  : streamly@composewell.com
-- Stability   : experimental
-- Portability : GHC
--
-- Parallel parsers. Distributing the input to multiple parsers at the same
-- time.
--
-- For simplicity, we are using code where a particular state is unreachable
-- but it is not prevented by types.  Somehow uni-pattern match using "let"
-- produces better optimized code compared to using @case@ match and using
-- explicit error messages in unreachable cases.
--
-- There seem to be no way to silence individual warnings so we use a global
-- incomplete uni-pattern match warning suppression option for the file.
-- Disabling the warning for other code as well  has the potential to mask off
-- some legit warnings, therefore, we have segregated only the code that uses
-- uni-pattern matches in this module.

module Streamly.Internal.Data.Parser.Tee
    (
    -- Parallel zipped
      teeWith
    , teeWithFst
    , teeWithMin

    -- Parallel alternatives
    , shortest
    , longest
    )
where

import Control.Exception (assert)
import Control.Monad.Catch (MonadCatch, try)
import Prelude
       hiding (any, all, takeWhile)

import Fusion.Plugin.Types (Fuse(..))
import Streamly.Internal.Data.Parser.Types (Parser(..), Step(..), ParseError)

-------------------------------------------------------------------------------
-- Distribute input to two parsers and collect both results
-------------------------------------------------------------------------------

{-# ANN type StepState Fuse #-}
data StepState s a = StepState s | StepResult a

-- XXX Use a Zipper structure for buffering?
--
-- | State of the pair of parsers in a tee composition
-- Note: strictness annotation is important for fusing the constructors
{-# ANN type TeeState Fuse #-}
data TeeState sL sR x a b =
-- @TeePair (past buffer, parser state, future-buffer1, future-buffer2) ...@
    TeePair !([x], StepState sL a, [x], [x]) !([x], StepState sR b, [x], [x])

{-# ANN type Res Fuse #-}
data Res = Yld Int | Stp Int | Skp | Err String

-- XXX: With the current "Step" semantics, it is hard to write, and not sure
-- how useful, an efficient teeWith that returns a correct unused input count.
--
-- XXX Teeing a parser with a Fold could be more useful and simpler to
-- implement. A fold never fails or backtracks so we do not need to buffer the
-- input for the fold. It can be useful in, for example, maintaining the line
-- and column number position to report for errors. We can always have the
-- line/column fold running in parallel with the main parser, whenever an error
-- occurs we can zip the error with the context fold.
--
-- | @teeWith f p1 p2@ distributes its input to both @p1@ and @p2@ until both
-- of them succeed or fail and combines their output using @f@. The parser
-- succeeds if both the parsers succeed.
--
-- /Internal/
--
{-# INLINE teeWith #-}
teeWith :: Monad m
    => (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c
teeWith :: (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c
teeWith a -> b -> c
zf (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) =
    (TeeState s s x a b -> x -> m (Step (TeeState s s x a b) c))
-> m (TeeState s s x a b)
-> (TeeState s s x a b -> 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 TeeState s s x a b -> x -> m (Step (TeeState s s x a b) c)
step m (TeeState s s x a b)
forall x a b. m (TeeState s s x a b)
initial TeeState s s x a b -> m c
forall x. TeeState s s x a b -> m c
extract

    where

    {-# INLINE_LATE initial #-}
    initial :: m (TeeState s s x a b)
initial = do
        s
sL <- m s
initialL
        s
sR <- m s
initialR
        TeeState s s x a b -> m (TeeState s s x a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (TeeState s s x a b -> m (TeeState s s x a b))
-> TeeState s s x a b -> m (TeeState s s x a b)
forall a b. (a -> b) -> a -> b
$ ([x], StepState s a, [x], [x])
-> ([x], StepState s b, [x], [x]) -> TeeState s s x a b
forall sL sR x a b.
([x], StepState sL a, [x], [x])
-> ([x], StepState sR b, [x], [x]) -> TeeState sL sR x a b
TeePair ([], s -> StepState s a
forall s a. s -> StepState s a
StepState s
sL, [], []) ([], s -> StepState s b
forall s a. s -> StepState s a
StepState s
sR, [], [])

    {-# INLINE consume #-}
    consume :: [t]
-> [t] -> [t] -> (t -> t -> m b) -> t -> t -> m ([t], b, [t], [t])
consume [t]
buf [t]
inp1 [t]
inp2 t -> t -> m b
stp t
st t
y = do
        let (t
x, [t]
inp11, [t]
inp21) =
                case [t]
inp1 of
                    [] -> (t
y, [], [])
                    z : [] -> (t
z, [t] -> [t]
forall a. [a] -> [a]
reverse (t
xt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
inp2), [])
                    z : zs -> (t
z, [t]
zs, t
xt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
inp2)
        b
r <- t -> t -> m b
stp t
st t
x
        let buf1 :: [t]
buf1 = t
xt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
buf
        ([t], b, [t], [t]) -> m ([t], b, [t], [t])
forall (m :: * -> *) a. Monad m => a -> m a
return ([t]
buf1, b
r, [t]
inp11, [t]
inp21)

    -- consume one input item and return the next state of the fold
    {-# INLINE useStream #-}
    useStream :: [a]
-> [a]
-> [a]
-> (t -> a -> m (Step s a))
-> t
-> a
-> m (([a], StepState s a, [a], [a]), Res)
useStream [a]
buf [a]
inp1 [a]
inp2 t -> a -> m (Step s a)
stp t
st a
y = do
        ([a]
buf1, Step s a
r, [a]
inp11, [a]
inp21) <- [a]
-> [a]
-> [a]
-> (t -> a -> m (Step s a))
-> t
-> a
-> m ([a], Step s a, [a], [a])
forall (m :: * -> *) t t b.
Monad m =>
[t]
-> [t] -> [t] -> (t -> t -> m b) -> t -> t -> m ([t], b, [t], [t])
consume [a]
buf [a]
inp1 [a]
inp2 t -> a -> m (Step s a)
stp t
st a
y
        case Step s a
r of
            Yield Int
n s
s ->
                let state :: ([a], StepState s a, [a], [a])
state = (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
Prelude.take Int
n [a]
buf1, s -> StepState s a
forall s a. s -> StepState s a
StepState s
s, [a]
inp11, [a]
inp21)
                 in Bool
-> m (([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
buf1) ((([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall (m :: * -> *) a. Monad m => a -> m a
return (([a], StepState s a, [a], [a])
forall a. ([a], StepState s a, [a], [a])
state, Int -> Res
Yld Int
n))
            Stop Int
n a
b ->
                let state :: ([a], StepState s a, [a], [a])
state = (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
Prelude.take Int
n [a]
buf1, a -> StepState s a
forall s a. a -> StepState s a
StepResult a
b, [a]
inp11, [a]
inp21)
                 in Bool
-> m (([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
buf1) ((([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall (m :: * -> *) a. Monad m => a -> m a
return (([a], StepState s a, [a], [a])
forall s. ([a], StepState s a, [a], [a])
state, Int -> Res
Stp Int
n))
            -- Skip 0 s -> (buf1, Right s, inp11, inp21)
            Skip Int
n s
s ->
                let ([a]
src0, [a]
buf2) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
buf1
                    src :: [a]
src  = [a] -> [a]
forall a. [a] -> [a]
Prelude.reverse [a]
src0
                    state :: ([a], StepState s a, [a], [a])
state = ([a]
buf2, s -> StepState s a
forall s a. s -> StepState s a
StepState s
s, [a]
src [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
inp11, [a]
inp21)
                 in Bool
-> m (([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
buf1) ((([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall (m :: * -> *) a. Monad m => a -> m a
return (([a], StepState s a, [a], [a])
forall a. ([a], StepState s a, [a], [a])
state, Res
Skp))
            Error String
err -> (([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall (m :: * -> *) a. Monad m => a -> m a
return (([a], StepState s a, [a], [a])
forall a. (?callStack::CallStack) => a
undefined, String -> Res
Err String
err)

    {-# INLINE_LATE step #-}
    step :: TeeState s s x a b -> x -> m (Step (TeeState s s x a b) c)
step (TeePair ([x]
bufL, StepState s
sL, [x]
inpL1, [x]
inpL2)
                  ([x]
bufR, StepState s
sR, [x]
inpR1, [x]
inpR2)) x
x = do
        (([x], StepState s a, [x], [x])
l,Res
stL) <- [x]
-> [x]
-> [x]
-> (s -> x -> m (Step s a))
-> s
-> x
-> m (([x], StepState s a, [x], [x]), Res)
forall (m :: * -> *) a t s a.
Monad m =>
[a]
-> [a]
-> [a]
-> (t -> a -> m (Step s a))
-> t
-> a
-> m (([a], StepState s a, [a], [a]), Res)
useStream [x]
bufL [x]
inpL1 [x]
inpL2 s -> x -> m (Step s a)
stepL s
sL x
x
        (([x], StepState s b, [x], [x])
r,Res
stR) <- [x]
-> [x]
-> [x]
-> (s -> x -> m (Step s b))
-> s
-> x
-> m (([x], StepState s b, [x], [x]), Res)
forall (m :: * -> *) a t s a.
Monad m =>
[a]
-> [a]
-> [a]
-> (t -> a -> m (Step s a))
-> t
-> a
-> m (([a], StepState s a, [a], [a]), Res)
useStream [x]
bufR [x]
inpR1 [x]
inpR2 s -> x -> m (Step s b)
stepR s
sR x
x
        let next :: TeeState s s x a b
next = ([x], StepState s a, [x], [x])
-> ([x], StepState s b, [x], [x]) -> TeeState s s x a b
forall sL sR x a b.
([x], StepState sL a, [x], [x])
-> ([x], StepState sR b, [x], [x]) -> TeeState sL sR x a b
TeePair ([x], StepState s a, [x], [x])
l ([x], StepState s b, [x], [x])
r
        Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c))
-> Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c)
forall a b. (a -> b) -> a -> b
$ case (Res
stL,Res
stR) of
            (Yld Int
n1, Yld Int
n2) -> Int -> TeeState s s x a b -> Step (TeeState s s x a b) c
forall s b. Int -> s -> Step s b
Yield (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n1 Int
n2) TeeState s s x a b
next
            (Yld Int
n1, Stp Int
n2) -> Int -> TeeState s s x a b -> Step (TeeState s s x a b) c
forall s b. Int -> s -> Step s b
Yield (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n1 Int
n2) TeeState s s x a b
next
            (Stp Int
n1, Yld Int
n2) -> Int -> TeeState s s x a b -> Step (TeeState s s x a b) c
forall s b. Int -> s -> Step s b
Yield (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n1 Int
n2) TeeState s s x a b
next
            (Stp Int
n1, Stp Int
n2) ->
                -- Uni-pattern match results in better optimized code compared
                -- to a case match.
                let ([x]
_, StepResult a
rL, [x]
_, [x]
_) = ([x], StepState s a, [x], [x])
l
                    ([x]
_, StepResult b
rR, [x]
_, [x]
_) = ([x], StepState s b, [x], [x])
r
                 in Int -> c -> Step (TeeState s s x a b) c
forall s b. Int -> b -> Step s b
Stop (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n1 Int
n2) (a -> b -> c
zf a
rL b
rR)
            (Err String
err, Res
_) -> String -> Step (TeeState s s x a b) c
forall s b. String -> Step s b
Error String
err
            (Res
_, Err String
err) -> String -> Step (TeeState s s x a b) c
forall s b. String -> Step s b
Error String
err
            (Res, Res)
_ -> Int -> TeeState s s x a b -> Step (TeeState s s x a b) c
forall s b. Int -> s -> Step s b
Skip Int
0 TeeState s s x a b
next

    step (TeePair ([x]
bufL, StepState s
sL, [x]
inpL1, [x]
inpL2)
                r :: ([x], StepState s b, [x], [x])
r@([x]
_, StepResult b
rR, [x]
_, [x]
_)) x
x = do
        (([x], StepState s a, [x], [x])
l,Res
stL) <- [x]
-> [x]
-> [x]
-> (s -> x -> m (Step s a))
-> s
-> x
-> m (([x], StepState s a, [x], [x]), Res)
forall (m :: * -> *) a t s a.
Monad m =>
[a]
-> [a]
-> [a]
-> (t -> a -> m (Step s a))
-> t
-> a
-> m (([a], StepState s a, [a], [a]), Res)
useStream [x]
bufL [x]
inpL1 [x]
inpL2 s -> x -> m (Step s a)
stepL s
sL x
x
        let next :: TeeState s s x a b
next = ([x], StepState s a, [x], [x])
-> ([x], StepState s b, [x], [x]) -> TeeState s s x a b
forall sL sR x a b.
([x], StepState sL a, [x], [x])
-> ([x], StepState sR b, [x], [x]) -> TeeState sL sR x a b
TeePair ([x], StepState s a, [x], [x])
l ([x], StepState s b, [x], [x])
r
        -- XXX If the unused count of this stream is lower than the unused
        -- count of the stopped stream, only then this will be correct. We need
        -- to fix the other case. We need to keep incrementing the unused count
        -- of the stopped stream and take the min of the two.
        Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c))
-> Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c)
forall a b. (a -> b) -> a -> b
$ case Res
stL of
            Yld Int
n -> Int -> TeeState s s x a b -> Step (TeeState s s x a b) c
forall s b. Int -> s -> Step s b
Yield Int
n TeeState s s x a b
next
            Stp Int
n ->
                let ([x]
_, StepResult a
rL, [x]
_, [x]
_) = ([x], StepState s a, [x], [x])
l
                 in Int -> c -> Step (TeeState s s x a b) c
forall s b. Int -> b -> Step s b
Stop Int
n (a -> b -> c
zf a
rL b
rR)
            Res
Skp -> Int -> TeeState s s x a b -> Step (TeeState s s x a b) c
forall s b. Int -> s -> Step s b
Skip Int
0 TeeState s s x a b
next
            Err String
err -> String -> Step (TeeState s s x a b) c
forall s b. String -> Step s b
Error String
err

    step (TeePair l :: ([x], StepState s a, [x], [x])
l@([x]
_, StepResult a
rL, [x]
_, [x]
_)
                    ([x]
bufR, StepState s
sR, [x]
inpR1, [x]
inpR2)) x
x = do
        (([x], StepState s b, [x], [x])
r, Res
stR) <- [x]
-> [x]
-> [x]
-> (s -> x -> m (Step s b))
-> s
-> x
-> m (([x], StepState s b, [x], [x]), Res)
forall (m :: * -> *) a t s a.
Monad m =>
[a]
-> [a]
-> [a]
-> (t -> a -> m (Step s a))
-> t
-> a
-> m (([a], StepState s a, [a], [a]), Res)
useStream [x]
bufR [x]
inpR1 [x]
inpR2 s -> x -> m (Step s b)
stepR s
sR x
x
        let next :: TeeState s s x a b
next = ([x], StepState s a, [x], [x])
-> ([x], StepState s b, [x], [x]) -> TeeState s s x a b
forall sL sR x a b.
([x], StepState sL a, [x], [x])
-> ([x], StepState sR b, [x], [x]) -> TeeState sL sR x a b
TeePair ([x], StepState s a, [x], [x])
l ([x], StepState s b, [x], [x])
r
        -- XXX If the unused count of this stream is lower than the unused
        -- count of the stopped stream, only then this will be correct. We need
        -- to fix the other case. We need to keep incrementing the unused count
        -- of the stopped stream and take the min of the two.
        Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c))
-> Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c)
forall a b. (a -> b) -> a -> b
$ case Res
stR of
            Yld Int
n -> Int -> TeeState s s x a b -> Step (TeeState s s x a b) c
forall s b. Int -> s -> Step s b
Yield Int
n TeeState s s x a b
next
            Stp Int
n ->
                let ([x]
_, StepResult b
rR, [x]
_, [x]
_) = ([x], StepState s b, [x], [x])
r
                 in Int -> c -> Step (TeeState s s x a b) c
forall s b. Int -> b -> Step s b
Stop Int
n (a -> b -> c
zf a
rL b
rR)
            Res
Skp -> Int -> TeeState s s x a b -> Step (TeeState s s x a b) c
forall s b. Int -> s -> Step s b
Skip Int
0 TeeState s s x a b
next
            Err String
err -> String -> Step (TeeState s s x a b) c
forall s b. String -> Step s b
Error String
err

    step TeeState s s x a b
_ x
_ = m (Step (TeeState s s x a b) c)
forall a. (?callStack::CallStack) => a
undefined

    {-# INLINE_LATE extract #-}
    extract :: TeeState s s x a b -> m c
extract TeeState s s x a b
st =
        case TeeState s s x a b
st of
            TeePair ([x]
_, StepState s
sL, [x]
_, [x]
_) ([x]
_, StepState s
sR, [x]
_, [x]
_) -> do
                a
rL <- s -> m a
extractL s
sL
                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
zf a
rL b
rR
            TeePair ([x]
_, StepState s
sL, [x]
_, [x]
_) ([x]
_, StepResult b
rR, [x]
_, [x]
_) -> do
                a
rL <- s -> m a
extractL s
sL
                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
zf a
rL b
rR
            TeePair ([x]
_, StepResult  a
rL, [x]
_, [x]
_) ([x]
_, StepState s
sR, [x]
_, [x]
_) -> do
                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
zf a
rL b
rR
            TeePair ([x]
_, StepResult a
rL, [x]
_, [x]
_) ([x]
_, StepResult b
rR, [x]
_, [x]
_) ->
                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
zf a
rL b
rR

-- | Like 'teeWith' but ends parsing and zips the results, if available,
-- whenever the first parser ends.
--
-- /Internal/
--
{-# INLINE teeWithFst #-}
teeWithFst :: Monad m
    => (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c
teeWithFst :: (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c
teeWithFst a -> b -> c
zf (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) =
    (TeeState s s x a b -> x -> m (Step (TeeState s s x a b) c))
-> m (TeeState s s x a b)
-> (TeeState s s x a b -> 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 TeeState s s x a b -> x -> m (Step (TeeState s s x a b) c)
forall a.
TeeState s s x a b -> x -> m (Step (TeeState s s x a b) c)
step m (TeeState s s x a b)
forall x a b. m (TeeState s s x a b)
initial TeeState s s x a b -> m c
forall x a. TeeState s s x a b -> m c
extract

    where

    {-# INLINE_LATE initial #-}
    initial :: m (TeeState s s x a b)
initial = do
        s
sL <- m s
initialL
        s
sR <- m s
initialR
        TeeState s s x a b -> m (TeeState s s x a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (TeeState s s x a b -> m (TeeState s s x a b))
-> TeeState s s x a b -> m (TeeState s s x a b)
forall a b. (a -> b) -> a -> b
$ ([x], StepState s a, [x], [x])
-> ([x], StepState s b, [x], [x]) -> TeeState s s x a b
forall sL sR x a b.
([x], StepState sL a, [x], [x])
-> ([x], StepState sR b, [x], [x]) -> TeeState sL sR x a b
TeePair ([], s -> StepState s a
forall s a. s -> StepState s a
StepState s
sL, [], []) ([], s -> StepState s b
forall s a. s -> StepState s a
StepState s
sR, [], [])

    {-# INLINE consume #-}
    consume :: [t]
-> [t] -> [t] -> (t -> t -> m b) -> t -> t -> m ([t], b, [t], [t])
consume [t]
buf [t]
inp1 [t]
inp2 t -> t -> m b
stp t
st t
y = do
        let (t
x, [t]
inp11, [t]
inp21) =
                case [t]
inp1 of
                    [] -> (t
y, [], [])
                    z : [] -> (t
z, [t] -> [t]
forall a. [a] -> [a]
reverse (t
xt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
inp2), [])
                    z : zs -> (t
z, [t]
zs, t
xt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
inp2)
        b
r <- t -> t -> m b
stp t
st t
x
        let buf1 :: [t]
buf1 = t
xt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
buf
        ([t], b, [t], [t]) -> m ([t], b, [t], [t])
forall (m :: * -> *) a. Monad m => a -> m a
return ([t]
buf1, b
r, [t]
inp11, [t]
inp21)

    -- consume one input item and return the next state of the fold
    {-# INLINE useStream #-}
    useStream :: [a]
-> [a]
-> [a]
-> (t -> a -> m (Step s a))
-> t
-> a
-> m (([a], StepState s a, [a], [a]), Res)
useStream [a]
buf [a]
inp1 [a]
inp2 t -> a -> m (Step s a)
stp t
st a
y = do
        ([a]
buf1, Step s a
r, [a]
inp11, [a]
inp21) <- [a]
-> [a]
-> [a]
-> (t -> a -> m (Step s a))
-> t
-> a
-> m ([a], Step s a, [a], [a])
forall (m :: * -> *) t t b.
Monad m =>
[t]
-> [t] -> [t] -> (t -> t -> m b) -> t -> t -> m ([t], b, [t], [t])
consume [a]
buf [a]
inp1 [a]
inp2 t -> a -> m (Step s a)
stp t
st a
y
        case Step s a
r of
            Yield Int
n s
s ->
                let state :: ([a], StepState s a, [a], [a])
state = (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
Prelude.take Int
n [a]
buf1, s -> StepState s a
forall s a. s -> StepState s a
StepState s
s, [a]
inp11, [a]
inp21)
                 in Bool
-> m (([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
buf1) ((([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall (m :: * -> *) a. Monad m => a -> m a
return (([a], StepState s a, [a], [a])
forall a. ([a], StepState s a, [a], [a])
state, Int -> Res
Yld Int
n))
            Stop Int
n a
b ->
                let state :: ([a], StepState s a, [a], [a])
state = (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
Prelude.take Int
n [a]
buf1, a -> StepState s a
forall s a. a -> StepState s a
StepResult a
b, [a]
inp11, [a]
inp21)
                 in Bool
-> m (([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
buf1) ((([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall (m :: * -> *) a. Monad m => a -> m a
return (([a], StepState s a, [a], [a])
forall s. ([a], StepState s a, [a], [a])
state, Int -> Res
Stp Int
n))
            -- Skip 0 s -> (buf1, Right s, inp11, inp21)
            Skip Int
n s
s ->
                let ([a]
src0, [a]
buf2) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
buf1
                    src :: [a]
src  = [a] -> [a]
forall a. [a] -> [a]
Prelude.reverse [a]
src0
                    state :: ([a], StepState s a, [a], [a])
state = ([a]
buf2, s -> StepState s a
forall s a. s -> StepState s a
StepState s
s, [a]
src [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
inp11, [a]
inp21)
                 in Bool
-> m (([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
buf1) ((([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall (m :: * -> *) a. Monad m => a -> m a
return (([a], StepState s a, [a], [a])
forall a. ([a], StepState s a, [a], [a])
state, Res
Skp))
            Error String
err -> (([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall (m :: * -> *) a. Monad m => a -> m a
return (([a], StepState s a, [a], [a])
forall a. (?callStack::CallStack) => a
undefined, String -> Res
Err String
err)

    {-# INLINE_LATE step #-}
    step :: TeeState s s x a b -> x -> m (Step (TeeState s s x a b) c)
step (TeePair ([x]
bufL, StepState s
sL, [x]
inpL1, [x]
inpL2)
                  ([x]
bufR, StepState s
sR, [x]
inpR1, [x]
inpR2)) x
x = do
        (([x], StepState s a, [x], [x])
l,Res
stL) <- [x]
-> [x]
-> [x]
-> (s -> x -> m (Step s a))
-> s
-> x
-> m (([x], StepState s a, [x], [x]), Res)
forall (m :: * -> *) a t s a.
Monad m =>
[a]
-> [a]
-> [a]
-> (t -> a -> m (Step s a))
-> t
-> a
-> m (([a], StepState s a, [a], [a]), Res)
useStream [x]
bufL [x]
inpL1 [x]
inpL2 s -> x -> m (Step s a)
stepL s
sL x
x
        (([x], StepState s b, [x], [x])
r,Res
stR) <- [x]
-> [x]
-> [x]
-> (s -> x -> m (Step s b))
-> s
-> x
-> m (([x], StepState s b, [x], [x]), Res)
forall (m :: * -> *) a t s a.
Monad m =>
[a]
-> [a]
-> [a]
-> (t -> a -> m (Step s a))
-> t
-> a
-> m (([a], StepState s a, [a], [a]), Res)
useStream [x]
bufR [x]
inpR1 [x]
inpR2 s -> x -> m (Step s b)
stepR s
sR x
x
        let next :: TeeState s s x a b
next = ([x], StepState s a, [x], [x])
-> ([x], StepState s b, [x], [x]) -> TeeState s s x a b
forall sL sR x a b.
([x], StepState sL a, [x], [x])
-> ([x], StepState sR b, [x], [x]) -> TeeState sL sR x a b
TeePair ([x], StepState s a, [x], [x])
l ([x], StepState s b, [x], [x])
r
        case (Res
stL,Res
stR) of
            -- XXX what if the first parser returns an unused count which is
            -- more than the second parser's unused count? It does not make
            -- sense for the second parser to consume more than the first
            -- parser. We reset the input cursor based on the first parser.
            -- Error out if the second one has consumed more then the first?
            (Stp Int
n1, Stp Int
_) ->
                -- Uni-pattern match results in better optimized code compared
                -- to a case match.
                let ([x]
_, StepResult a
rL, [x]
_, [x]
_) = ([x], StepState s a, [x], [x])
l
                    ([x]
_, StepResult b
rR, [x]
_, [x]
_) = ([x], StepState s b, [x], [x])
r
                 in Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c))
-> Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c)
forall a b. (a -> b) -> a -> b
$ Int -> c -> Step (TeeState s s x a b) c
forall s b. Int -> b -> Step s b
Stop Int
n1 (a -> b -> c
zf a
rL b
rR)
            (Stp Int
n1, Yld Int
_) ->
                let ([x]
_, StepResult a
rL, [x]
_, [x]
_) = ([x], StepState s a, [x], [x])
l
                    ([x]
_, StepState  s
ssR, [x]
_, [x]
_) = ([x], StepState s b, [x], [x])
r
                 in do
                    b
rR <- s -> m b
extractR s
ssR
                    Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c))
-> Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c)
forall a b. (a -> b) -> a -> b
$ Int -> c -> Step (TeeState s s x a b) c
forall s b. Int -> b -> Step s b
Stop Int
n1 (a -> b -> c
zf a
rL b
rR)
            (Yld Int
n1, Yld Int
n2) -> Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c))
-> Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c)
forall a b. (a -> b) -> a -> b
$ Int -> TeeState s s x a b -> Step (TeeState s s x a b) c
forall s b. Int -> s -> Step s b
Yield (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n1 Int
n2) TeeState s s x a b
next
            (Yld Int
n1, Stp Int
n2) -> Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c))
-> Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c)
forall a b. (a -> b) -> a -> b
$ Int -> TeeState s s x a b -> Step (TeeState s s x a b) c
forall s b. Int -> s -> Step s b
Yield (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n1 Int
n2) TeeState s s x a b
next
            (Err String
err, Res
_) -> Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c))
-> Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c)
forall a b. (a -> b) -> a -> b
$ String -> Step (TeeState s s x a b) c
forall s b. String -> Step s b
Error String
err
            (Res
_, Err String
err) -> Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c))
-> Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c)
forall a b. (a -> b) -> a -> b
$ String -> Step (TeeState s s x a b) c
forall s b. String -> Step s b
Error String
err
            (Res, Res)
_ -> Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c))
-> Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c)
forall a b. (a -> b) -> a -> b
$ Int -> TeeState s s x a b -> Step (TeeState s s x a b) c
forall s b. Int -> s -> Step s b
Skip Int
0 TeeState s s x a b
next

    step (TeePair ([x]
bufL, StepState s
sL, [x]
inpL1, [x]
inpL2)
                r :: ([x], StepState s b, [x], [x])
r@([x]
_, StepResult b
rR, [x]
_, [x]
_)) x
x = do
        (([x], StepState s a, [x], [x])
l,Res
stL) <- [x]
-> [x]
-> [x]
-> (s -> x -> m (Step s a))
-> s
-> x
-> m (([x], StepState s a, [x], [x]), Res)
forall (m :: * -> *) a t s a.
Monad m =>
[a]
-> [a]
-> [a]
-> (t -> a -> m (Step s a))
-> t
-> a
-> m (([a], StepState s a, [a], [a]), Res)
useStream [x]
bufL [x]
inpL1 [x]
inpL2 s -> x -> m (Step s a)
stepL s
sL x
x
        let next :: TeeState s s x a b
next = ([x], StepState s a, [x], [x])
-> ([x], StepState s b, [x], [x]) -> TeeState s s x a b
forall sL sR x a b.
([x], StepState sL a, [x], [x])
-> ([x], StepState sR b, [x], [x]) -> TeeState sL sR x a b
TeePair ([x], StepState s a, [x], [x])
l ([x], StepState s b, [x], [x])
r
        -- XXX If the unused count of this stream is lower than the unused
        -- count of the stopped stream, only then this will be correct. We need
        -- to fix the other case. We need to keep incrementing the unused count
        -- of the stopped stream and take the min of the two.
        Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c))
-> Step (TeeState s s x a b) c -> m (Step (TeeState s s x a b) c)
forall a b. (a -> b) -> a -> b
$ case Res
stL of
            Yld Int
n -> Int -> TeeState s s x a b -> Step (TeeState s s x a b) c
forall s b. Int -> s -> Step s b
Yield Int
n TeeState s s x a b
next
            Stp Int
n ->
                let ([x]
_, StepResult a
rL, [x]
_, [x]
_) = ([x], StepState s a, [x], [x])
l
                 in Int -> c -> Step (TeeState s s x a b) c
forall s b. Int -> b -> Step s b
Stop Int
n (a -> b -> c
zf a
rL b
rR)
            Res
Skp -> Int -> TeeState s s x a b -> Step (TeeState s s x a b) c
forall s b. Int -> s -> Step s b
Skip Int
0 TeeState s s x a b
next
            Err String
err -> String -> Step (TeeState s s x a b) c
forall s b. String -> Step s b
Error String
err

    step TeeState s s x a b
_ x
_ = m (Step (TeeState s s x a b) c)
forall a. (?callStack::CallStack) => a
undefined

    {-# INLINE_LATE extract #-}
    extract :: TeeState s s x a b -> m c
extract TeeState s s x a b
st =
        case TeeState s s x a b
st of
            TeePair ([x]
_, StepState s
sL, [x]
_, [x]
_) ([x]
_, StepState s
sR, [x]
_, [x]
_) -> do
                a
rL <- s -> m a
extractL s
sL
                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
zf a
rL b
rR
            TeePair ([x]
_, StepState s
sL, [x]
_, [x]
_) ([x]
_, StepResult b
rR, [x]
_, [x]
_) -> do
                a
rL <- s -> m a
extractL s
sL
                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
zf a
rL b
rR
            TeeState s s x a b
_ -> String -> m c
forall a. (?callStack::CallStack) => String -> a
error String
"unreachable"

-- | Like 'teeWith' but ends parsing and zips the results, if available,
-- whenever any of the parsers ends or fails.
--
-- /Unimplemented/
--
{-# INLINE teeWithMin #-}
teeWithMin ::
    -- Monad m =>
    (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c
teeWithMin :: (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c
teeWithMin = (a -> b -> c) -> Parser m x a -> Parser m x b -> Parser m x c
forall a. (?callStack::CallStack) => a
undefined

-------------------------------------------------------------------------------
-- Distribute input to two parsers and choose one result
-------------------------------------------------------------------------------

-- | Shortest alternative. Apply both parsers in parallel but choose the result
-- from the one which consumed least input i.e. take the shortest succeeding
-- parse.
--
-- /Internal/
--
{-# INLINE shortest #-}
shortest :: Monad m => Parser m x a -> Parser m x a -> Parser m x a
shortest :: Parser m x a -> Parser m x a -> Parser m x a
shortest (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
_) =
    (TeeState s s x a a -> x -> m (Step (TeeState s s x a a) a))
-> m (TeeState s s x a a)
-> (TeeState s s x a a -> 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 TeeState s s x a a -> x -> m (Step (TeeState s s x a a) a)
forall a b.
TeeState s s x a b -> x -> m (Step (TeeState s s x a a) a)
step m (TeeState s s x a a)
forall x a b. m (TeeState s s x a b)
initial TeeState s s x a a -> m a
forall sR x a b. TeeState s sR x a b -> m a
extract

    where

    {-# INLINE_LATE initial #-}
    initial :: m (TeeState s s x a b)
initial = do
        s
sL <- m s
initialL
        s
sR <- m s
initialR
        TeeState s s x a b -> m (TeeState s s x a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (TeeState s s x a b -> m (TeeState s s x a b))
-> TeeState s s x a b -> m (TeeState s s x a b)
forall a b. (a -> b) -> a -> b
$ ([x], StepState s a, [x], [x])
-> ([x], StepState s b, [x], [x]) -> TeeState s s x a b
forall sL sR x a b.
([x], StepState sL a, [x], [x])
-> ([x], StepState sR b, [x], [x]) -> TeeState sL sR x a b
TeePair ([], s -> StepState s a
forall s a. s -> StepState s a
StepState s
sL, [], []) ([], s -> StepState s b
forall s a. s -> StepState s a
StepState s
sR, [], [])

    {-# INLINE consume #-}
    consume :: [t]
-> [t] -> [t] -> (t -> t -> m b) -> t -> t -> m ([t], b, [t], [t])
consume [t]
buf [t]
inp1 [t]
inp2 t -> t -> m b
stp t
st t
y = do
        let (t
x, [t]
inp11, [t]
inp21) =
                case [t]
inp1 of
                    [] -> (t
y, [], [])
                    z : [] -> (t
z, [t] -> [t]
forall a. [a] -> [a]
reverse (t
xt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
inp2), [])
                    z : zs -> (t
z, [t]
zs, t
xt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
inp2)
        b
r <- t -> t -> m b
stp t
st t
x
        let buf1 :: [t]
buf1 = t
xt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
buf
        ([t], b, [t], [t]) -> m ([t], b, [t], [t])
forall (m :: * -> *) a. Monad m => a -> m a
return ([t]
buf1, b
r, [t]
inp11, [t]
inp21)

    -- consume one input item and return the next state of the fold
    {-# INLINE useStream #-}
    useStream :: [a]
-> [a]
-> [a]
-> (t -> a -> m (Step s a))
-> t
-> a
-> m (([a], StepState s a, [a], [a]), Res)
useStream [a]
buf [a]
inp1 [a]
inp2 t -> a -> m (Step s a)
stp t
st a
y = do
        ([a]
buf1, Step s a
r, [a]
inp11, [a]
inp21) <- [a]
-> [a]
-> [a]
-> (t -> a -> m (Step s a))
-> t
-> a
-> m ([a], Step s a, [a], [a])
forall (m :: * -> *) t t b.
Monad m =>
[t]
-> [t] -> [t] -> (t -> t -> m b) -> t -> t -> m ([t], b, [t], [t])
consume [a]
buf [a]
inp1 [a]
inp2 t -> a -> m (Step s a)
stp t
st a
y
        case Step s a
r of
            Yield Int
n s
s ->
                let state :: ([a], StepState s a, [a], [a])
state = (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
Prelude.take Int
n [a]
buf1, s -> StepState s a
forall s a. s -> StepState s a
StepState s
s, [a]
inp11, [a]
inp21)
                 in Bool
-> m (([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
buf1) ((([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall (m :: * -> *) a. Monad m => a -> m a
return (([a], StepState s a, [a], [a])
forall a. ([a], StepState s a, [a], [a])
state, Int -> Res
Yld Int
n))
            Stop Int
n a
b ->
                let state :: ([a], StepState s a, [a], [a])
state = (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
Prelude.take Int
n [a]
buf1, a -> StepState s a
forall s a. a -> StepState s a
StepResult a
b, [a]
inp11, [a]
inp21)
                 in Bool
-> m (([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
buf1) ((([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall (m :: * -> *) a. Monad m => a -> m a
return (([a], StepState s a, [a], [a])
forall s. ([a], StepState s a, [a], [a])
state, Int -> Res
Stp Int
n))
            -- Skip 0 s -> (buf1, Right s, inp11, inp21)
            Skip Int
n s
s ->
                let ([a]
src0, [a]
buf2) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
buf1
                    src :: [a]
src  = [a] -> [a]
forall a. [a] -> [a]
Prelude.reverse [a]
src0
                    state :: ([a], StepState s a, [a], [a])
state = ([a]
buf2, s -> StepState s a
forall s a. s -> StepState s a
StepState s
s, [a]
src [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
inp11, [a]
inp21)
                 in Bool
-> m (([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
buf1) ((([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall (m :: * -> *) a. Monad m => a -> m a
return (([a], StepState s a, [a], [a])
forall a. ([a], StepState s a, [a], [a])
state, Res
Skp))
            Error String
err -> (([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall (m :: * -> *) a. Monad m => a -> m a
return (([a], StepState s a, [a], [a])
forall a. (?callStack::CallStack) => a
undefined, String -> Res
Err String
err)

    -- XXX Even if a parse finished earlier it may not be shortest if the other
    -- parser finishes later but returns a lot of unconsumed input. Our current
    -- criterion of shortest is whichever parse decided to stop earlier.
    {-# INLINE_LATE step #-}
    step :: TeeState s s x a b -> x -> m (Step (TeeState s s x a a) a)
step (TeePair ([x]
bufL, StepState s
sL, [x]
inpL1, [x]
inpL2)
                  ([x]
bufR, StepState s
sR, [x]
inpR1, [x]
inpR2)) x
x = do
        (([x], StepState s a, [x], [x])
l,Res
stL) <- [x]
-> [x]
-> [x]
-> (s -> x -> m (Step s a))
-> s
-> x
-> m (([x], StepState s a, [x], [x]), Res)
forall (m :: * -> *) a t s a.
Monad m =>
[a]
-> [a]
-> [a]
-> (t -> a -> m (Step s a))
-> t
-> a
-> m (([a], StepState s a, [a], [a]), Res)
useStream [x]
bufL [x]
inpL1 [x]
inpL2 s -> x -> m (Step s a)
stepL s
sL x
x
        (([x], StepState s a, [x], [x])
r,Res
stR) <- [x]
-> [x]
-> [x]
-> (s -> x -> m (Step s a))
-> s
-> x
-> m (([x], StepState s a, [x], [x]), Res)
forall (m :: * -> *) a t s a.
Monad m =>
[a]
-> [a]
-> [a]
-> (t -> a -> m (Step s a))
-> t
-> a
-> m (([a], StepState s a, [a], [a]), Res)
useStream [x]
bufR [x]
inpR1 [x]
inpR2 s -> x -> m (Step s a)
stepR s
sR x
x
        let next :: TeeState s s x a a
next = ([x], StepState s a, [x], [x])
-> ([x], StepState s a, [x], [x]) -> TeeState s s x a a
forall sL sR x a b.
([x], StepState sL a, [x], [x])
-> ([x], StepState sR b, [x], [x]) -> TeeState sL sR x a b
TeePair ([x], StepState s a, [x], [x])
l ([x], StepState s a, [x], [x])
r
        Step (TeeState s s x a a) a -> m (Step (TeeState s s x a a) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (TeeState s s x a a) a -> m (Step (TeeState s s x a a) a))
-> Step (TeeState s s x a a) a -> m (Step (TeeState s s x a a) a)
forall a b. (a -> b) -> a -> b
$ case (Res
stL,Res
stR) of
            (Stp Int
n1, Res
_) ->
                let ([x]
_, StepResult a
rL, [x]
_, [x]
_) = ([x], StepState s a, [x], [x])
l
                 in Int -> a -> Step (TeeState s s x a a) a
forall s b. Int -> b -> Step s b
Stop Int
n1 a
rL
            (Res
_, Stp Int
n2) ->
                let ([x]
_, StepResult a
rR, [x]
_, [x]
_) = ([x], StepState s a, [x], [x])
r
                 in Int -> a -> Step (TeeState s s x a a) a
forall s b. Int -> b -> Step s b
Stop Int
n2 a
rR
            (Yld Int
n1, Yld Int
n2) -> Int -> TeeState s s x a a -> Step (TeeState s s x a a) a
forall s b. Int -> s -> Step s b
Yield (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n1 Int
n2) TeeState s s x a a
next
            (Err String
err, Res
_) -> String -> Step (TeeState s s x a a) a
forall s b. String -> Step s b
Error String
err
            (Res
_, Err String
err) -> String -> Step (TeeState s s x a a) a
forall s b. String -> Step s b
Error String
err
            (Res, Res)
_ -> Int -> TeeState s s x a a -> Step (TeeState s s x a a) a
forall s b. Int -> s -> Step s b
Skip Int
0 TeeState s s x a a
next

    step TeeState s s x a b
_ x
_ = m (Step (TeeState s s x a a) a)
forall a. (?callStack::CallStack) => a
undefined

    {-# INLINE_LATE extract #-}
    extract :: TeeState s sR x a b -> m a
extract TeeState s sR x a b
st =
        case TeeState s sR x a b
st of
            TeePair ([x]
_, StepState s
sL, [x]
_, [x]
_) ([x], StepState sR b, [x], [x])
_ -> s -> m a
extractL s
sL
            TeeState s sR x a b
_ -> String -> m a
forall a. (?callStack::CallStack) => String -> a
error String
"unreachable"

-- | Longest alternative. Apply both parsers in parallel but choose the result
-- from the one which consumed more input i.e. take the longest succeeding
-- parse.
--
-- /Internal/
--
{-# INLINE longest #-}
longest :: MonadCatch m => Parser m x a -> Parser m x a -> Parser m x a
longest :: Parser m x a -> Parser m x a -> Parser m x a
longest (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) =
    (TeeState s s x a a -> x -> m (Step (TeeState s s x a a) a))
-> m (TeeState s s x a a)
-> (TeeState s s x a a -> 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 TeeState s s x a a -> x -> m (Step (TeeState s s x a a) a)
step m (TeeState s s x a a)
forall x a b. m (TeeState s s x a b)
initial TeeState s s x a a -> m a
forall x. TeeState s s x a a -> m a
extract

    where

    {-# INLINE_LATE initial #-}
    initial :: m (TeeState s s x a b)
initial = do
        s
sL <- m s
initialL
        s
sR <- m s
initialR
        TeeState s s x a b -> m (TeeState s s x a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (TeeState s s x a b -> m (TeeState s s x a b))
-> TeeState s s x a b -> m (TeeState s s x a b)
forall a b. (a -> b) -> a -> b
$ ([x], StepState s a, [x], [x])
-> ([x], StepState s b, [x], [x]) -> TeeState s s x a b
forall sL sR x a b.
([x], StepState sL a, [x], [x])
-> ([x], StepState sR b, [x], [x]) -> TeeState sL sR x a b
TeePair ([], s -> StepState s a
forall s a. s -> StepState s a
StepState s
sL, [], []) ([], s -> StepState s b
forall s a. s -> StepState s a
StepState s
sR, [], [])

    {-# INLINE consume #-}
    consume :: [t]
-> [t] -> [t] -> (t -> t -> m b) -> t -> t -> m ([t], b, [t], [t])
consume [t]
buf [t]
inp1 [t]
inp2 t -> t -> m b
stp t
st t
y = do
        let (t
x, [t]
inp11, [t]
inp21) =
                case [t]
inp1 of
                    [] -> (t
y, [], [])
                    z : [] -> (t
z, [t] -> [t]
forall a. [a] -> [a]
reverse (t
xt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
inp2), [])
                    z : zs -> (t
z, [t]
zs, t
xt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
inp2)
        b
r <- t -> t -> m b
stp t
st t
x
        let buf1 :: [t]
buf1 = t
xt -> [t] -> [t]
forall a. a -> [a] -> [a]
:[t]
buf
        ([t], b, [t], [t]) -> m ([t], b, [t], [t])
forall (m :: * -> *) a. Monad m => a -> m a
return ([t]
buf1, b
r, [t]
inp11, [t]
inp21)

    -- consume one input item and return the next state of the fold
    {-# INLINE useStream #-}
    useStream :: [a]
-> [a]
-> [a]
-> (t -> a -> m (Step s a))
-> t
-> a
-> m (([a], StepState s a, [a], [a]), Res)
useStream [a]
buf [a]
inp1 [a]
inp2 t -> a -> m (Step s a)
stp t
st a
y = do
        ([a]
buf1, Step s a
r, [a]
inp11, [a]
inp21) <- [a]
-> [a]
-> [a]
-> (t -> a -> m (Step s a))
-> t
-> a
-> m ([a], Step s a, [a], [a])
forall (m :: * -> *) t t b.
Monad m =>
[t]
-> [t] -> [t] -> (t -> t -> m b) -> t -> t -> m ([t], b, [t], [t])
consume [a]
buf [a]
inp1 [a]
inp2 t -> a -> m (Step s a)
stp t
st a
y
        case Step s a
r of
            Yield Int
n s
s ->
                let state :: ([a], StepState s a, [a], [a])
state = (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
Prelude.take Int
n [a]
buf1, s -> StepState s a
forall s a. s -> StepState s a
StepState s
s, [a]
inp11, [a]
inp21)
                 in Bool
-> m (([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
buf1) ((([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall (m :: * -> *) a. Monad m => a -> m a
return (([a], StepState s a, [a], [a])
forall a. ([a], StepState s a, [a], [a])
state, Int -> Res
Yld Int
n))
            Stop Int
n a
b ->
                let state :: ([a], StepState s a, [a], [a])
state = (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
Prelude.take Int
n [a]
buf1, a -> StepState s a
forall s a. a -> StepState s a
StepResult a
b, [a]
inp11, [a]
inp21)
                 in Bool
-> m (([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
buf1) ((([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall (m :: * -> *) a. Monad m => a -> m a
return (([a], StepState s a, [a], [a])
forall s. ([a], StepState s a, [a], [a])
state, Int -> Res
Stp Int
n))
            -- Skip 0 s -> (buf1, Right s, inp11, inp21)
            Skip Int
n s
s ->
                let ([a]
src0, [a]
buf2) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
buf1
                    src :: [a]
src  = [a] -> [a]
forall a. [a] -> [a]
Prelude.reverse [a]
src0
                    state :: ([a], StepState s a, [a], [a])
state = ([a]
buf2, s -> StepState s a
forall s a. s -> StepState s a
StepState s
s, [a]
src [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
inp11, [a]
inp21)
                 in Bool
-> m (([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
buf1) ((([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall (m :: * -> *) a. Monad m => a -> m a
return (([a], StepState s a, [a], [a])
forall a. ([a], StepState s a, [a], [a])
state, Res
Skp))
            Error String
err -> (([a], StepState s a, [a], [a]), Res)
-> m (([a], StepState s a, [a], [a]), Res)
forall (m :: * -> *) a. Monad m => a -> m a
return (([a], StepState s a, [a], [a])
forall a. (?callStack::CallStack) => a
undefined, String -> Res
Err String
err)

    {-# INLINE_LATE step #-}
    step :: TeeState s s x a a -> x -> m (Step (TeeState s s x a a) a)
step (TeePair ([x]
bufL, StepState s
sL, [x]
inpL1, [x]
inpL2)
                  ([x]
bufR, StepState s
sR, [x]
inpR1, [x]
inpR2)) x
x = do
        (([x], StepState s a, [x], [x])
l,Res
stL) <- [x]
-> [x]
-> [x]
-> (s -> x -> m (Step s a))
-> s
-> x
-> m (([x], StepState s a, [x], [x]), Res)
forall (m :: * -> *) a t s a.
Monad m =>
[a]
-> [a]
-> [a]
-> (t -> a -> m (Step s a))
-> t
-> a
-> m (([a], StepState s a, [a], [a]), Res)
useStream [x]
bufL [x]
inpL1 [x]
inpL2 s -> x -> m (Step s a)
stepL s
sL x
x
        (([x], StepState s a, [x], [x])
r,Res
stR) <- [x]
-> [x]
-> [x]
-> (s -> x -> m (Step s a))
-> s
-> x
-> m (([x], StepState s a, [x], [x]), Res)
forall (m :: * -> *) a t s a.
Monad m =>
[a]
-> [a]
-> [a]
-> (t -> a -> m (Step s a))
-> t
-> a
-> m (([a], StepState s a, [a], [a]), Res)
useStream [x]
bufR [x]
inpR1 [x]
inpR2 s -> x -> m (Step s a)
stepR s
sR x
x
        let next :: TeeState s s x a a
next = ([x], StepState s a, [x], [x])
-> ([x], StepState s a, [x], [x]) -> TeeState s s x a a
forall sL sR x a b.
([x], StepState sL a, [x], [x])
-> ([x], StepState sR b, [x], [x]) -> TeeState sL sR x a b
TeePair ([x], StepState s a, [x], [x])
l ([x], StepState s a, [x], [x])
r
        Step (TeeState s s x a a) a -> m (Step (TeeState s s x a a) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (TeeState s s x a a) a -> m (Step (TeeState s s x a a) a))
-> Step (TeeState s s x a a) a -> m (Step (TeeState s s x a a) a)
forall a b. (a -> b) -> a -> b
$ case (Res
stL,Res
stR) of
            (Yld Int
n1, Yld Int
n2) -> Int -> TeeState s s x a a -> Step (TeeState s s x a a) a
forall s b. Int -> s -> Step s b
Yield (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n1 Int
n2) TeeState s s x a a
next
            (Yld Int
n1, Stp Int
n2) -> Int -> TeeState s s x a a -> Step (TeeState s s x a a) a
forall s b. Int -> s -> Step s b
Yield (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n1 Int
n2) TeeState s s x a a
next
            (Stp Int
n1, Yld Int
n2) -> Int -> TeeState s s x a a -> Step (TeeState s s x a a) a
forall s b. Int -> s -> Step s b
Yield (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n1 Int
n2) TeeState s s x a a
next
            (Stp Int
n1, Stp Int
n2) ->
                let ([x]
_, StepResult a
rL, [x]
_, [x]
_) = ([x], StepState s a, [x], [x])
l
                    ([x]
_, StepResult a
rR, [x]
_, [x]
_) = ([x], StepState s a, [x], [x])
r
                 in Int -> a -> Step (TeeState s s x a a) a
forall s b. Int -> b -> Step s b
Stop (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
n1 Int
n2) (if Int
n1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n2 then a
rL else a
rR)
            (Err String
err, Res
_) -> String -> Step (TeeState s s x a a) a
forall s b. String -> Step s b
Error String
err
            (Res
_, Err String
err) -> String -> Step (TeeState s s x a a) a
forall s b. String -> Step s b
Error String
err
            (Res, Res)
_ -> Int -> TeeState s s x a a -> Step (TeeState s s x a a) a
forall s b. Int -> s -> Step s b
Skip Int
0 TeeState s s x a a
next

    -- XXX the parser that finishes last may not be the longest because it may
    -- return a lot of unused input which makes it shorter. Our current
    -- criterion of deciding longest is based on whoever decides to finish
    -- last and not whoever consumed more input.
    --
    -- To actually know who made more progress we need to keep an account of
    -- how many items are unconsumed since the last yield.
    --
    step (TeePair ([x]
bufL, StepState s
sL, [x]
inpL1, [x]
inpL2)
                r :: ([x], StepState s a, [x], [x])
r@([x]
_, StepResult a
_, [x]
_, [x]
_)) x
x = do
        (([x], StepState s a, [x], [x])
l,Res
stL) <- [x]
-> [x]
-> [x]
-> (s -> x -> m (Step s a))
-> s
-> x
-> m (([x], StepState s a, [x], [x]), Res)
forall (m :: * -> *) a t s a.
Monad m =>
[a]
-> [a]
-> [a]
-> (t -> a -> m (Step s a))
-> t
-> a
-> m (([a], StepState s a, [a], [a]), Res)
useStream [x]
bufL [x]
inpL1 [x]
inpL2 s -> x -> m (Step s a)
stepL s
sL x
x
        let next :: TeeState s s x a a
next = ([x], StepState s a, [x], [x])
-> ([x], StepState s a, [x], [x]) -> TeeState s s x a a
forall sL sR x a b.
([x], StepState sL a, [x], [x])
-> ([x], StepState sR b, [x], [x]) -> TeeState sL sR x a b
TeePair ([x], StepState s a, [x], [x])
l ([x], StepState s a, [x], [x])
r
        Step (TeeState s s x a a) a -> m (Step (TeeState s s x a a) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (TeeState s s x a a) a -> m (Step (TeeState s s x a a) a))
-> Step (TeeState s s x a a) a -> m (Step (TeeState s s x a a) a)
forall a b. (a -> b) -> a -> b
$ case Res
stL of
            Yld Int
n -> Int -> TeeState s s x a a -> Step (TeeState s s x a a) a
forall s b. Int -> s -> Step s b
Yield Int
n TeeState s s x a a
next
            Stp Int
n ->
                let ([x]
_, StepResult a
rL, [x]
_, [x]
_) = ([x], StepState s a, [x], [x])
l
                 in Int -> a -> Step (TeeState s s x a a) a
forall s b. Int -> b -> Step s b
Stop Int
n a
rL
            Res
Skp -> Int -> TeeState s s x a a -> Step (TeeState s s x a a) a
forall s b. Int -> s -> Step s b
Skip Int
0 TeeState s s x a a
next
            Err String
err -> String -> Step (TeeState s s x a a) a
forall s b. String -> Step s b
Error String
err

    step (TeePair l :: ([x], StepState s a, [x], [x])
l@([x]
_, StepResult a
_, [x]
_, [x]
_)
                    ([x]
bufR, StepState s
sR, [x]
inpR1, [x]
inpR2)) x
x = do
        (([x], StepState s a, [x], [x])
r, Res
stR) <- [x]
-> [x]
-> [x]
-> (s -> x -> m (Step s a))
-> s
-> x
-> m (([x], StepState s a, [x], [x]), Res)
forall (m :: * -> *) a t s a.
Monad m =>
[a]
-> [a]
-> [a]
-> (t -> a -> m (Step s a))
-> t
-> a
-> m (([a], StepState s a, [a], [a]), Res)
useStream [x]
bufR [x]
inpR1 [x]
inpR2 s -> x -> m (Step s a)
stepR s
sR x
x
        let next :: TeeState s s x a a
next = ([x], StepState s a, [x], [x])
-> ([x], StepState s a, [x], [x]) -> TeeState s s x a a
forall sL sR x a b.
([x], StepState sL a, [x], [x])
-> ([x], StepState sR b, [x], [x]) -> TeeState sL sR x a b
TeePair ([x], StepState s a, [x], [x])
l ([x], StepState s a, [x], [x])
r
        Step (TeeState s s x a a) a -> m (Step (TeeState s s x a a) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Step (TeeState s s x a a) a -> m (Step (TeeState s s x a a) a))
-> Step (TeeState s s x a a) a -> m (Step (TeeState s s x a a) a)
forall a b. (a -> b) -> a -> b
$ case Res
stR of
            Yld Int
n -> Int -> TeeState s s x a a -> Step (TeeState s s x a a) a
forall s b. Int -> s -> Step s b
Yield Int
n TeeState s s x a a
next
            Stp Int
n ->
                let ([x]
_, StepResult a
rR, [x]
_, [x]
_) = ([x], StepState s a, [x], [x])
r
                 in Int -> a -> Step (TeeState s s x a a) a
forall s b. Int -> b -> Step s b
Stop Int
n a
rR
            Res
Skp -> Int -> TeeState s s x a a -> Step (TeeState s s x a a) a
forall s b. Int -> s -> Step s b
Skip Int
0 TeeState s s x a a
next
            Err String
err -> String -> Step (TeeState s s x a a) a
forall s b. String -> Step s b
Error String
err

    step TeeState s s x a a
_ x
_ = m (Step (TeeState s s x a a) a)
forall a. (?callStack::CallStack) => a
undefined

    {-# INLINE_LATE extract #-}
    extract :: TeeState s s x a a -> m a
extract TeeState s s x a a
st =
        -- XXX When results are partial we may not be able to precisely compare
        -- which parser has made more progress till now.  One way to do that is
        -- to figure out the actually consumed input up to the last yield.
        --
        case TeeState s s x a a
st of
            TeePair ([x]
_, StepState s
sL, [x]
_, [x]
_) ([x]
_, StepState s
sR, [x]
_, [x]
_) -> do
                Either ParseError a
r <- m a -> m (Either ParseError a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (m a -> m (Either ParseError a)) -> m a -> m (Either ParseError a)
forall a b. (a -> b) -> a -> b
$ s -> m a
extractL s
sL
                case Either ParseError a
r of
                    Left (ParseError
_ :: ParseError) -> s -> m a
extractR s
sR
                    Right a
b -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
b
            TeePair ([x]
_, StepState s
sL, [x]
_, [x]
_) ([x]
_, StepResult a
rR, [x]
_, [x]
_) -> do
                Either ParseError a
r <- m a -> m (Either ParseError a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (m a -> m (Either ParseError a)) -> m a -> m (Either ParseError a)
forall a b. (a -> b) -> a -> b
$ s -> m a
extractL s
sL
                case Either ParseError a
r of
                    Left (ParseError
_ :: ParseError) -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
rR
                    Right a
b -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
b
            TeePair ([x]
_, StepResult a
rL, [x]
_, [x]
_) ([x]
_, StepState s
sR, [x]
_, [x]
_) -> do
                Either ParseError a
r <- m a -> m (Either ParseError a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (m a -> m (Either ParseError a)) -> m a -> m (Either ParseError a)
forall a b. (a -> b) -> a -> b
$ s -> m a
extractR s
sR
                case Either ParseError a
r of
                    Left (ParseError
_ :: ParseError) -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
rL
                    Right a
b -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
b
            TeePair ([x]
_, StepResult a
_, [x]
_, [x]
_) ([x]
_, StepResult a
_, [x]
_, [x]
_) ->
                String -> m a
forall a. (?callStack::CallStack) => String -> a
error String
"unreachable"