{-# LANGUAGE UndecidableInstances #-}
#include "inline.hs"

-- |
-- Module      : Streamly.Internal.Data.Parser.ParserK.Type
-- Copyright   : (c) 2020 Composewell Technologies
-- License     : BSD-3-Clause
-- Maintainer  : streamly@composewell.com
-- Stability   : experimental
-- Portability : GHC
--
-- CPS style implementation of parsers.
--
-- The CPS representation allows linear performance for Applicative, sequenceA,
-- Monad, sequence, and Alternative, choice operations compared to the
-- quadratic complexity of the corresponding direct style operations. However,
-- direct style operations allow fusion with ~10x better performance than CPS.
--
-- The direct style representation does not allow for recursive definitions of
-- "some" and "many" whereas CPS allows that.

module Streamly.Internal.Data.Parser.ParserK.Type
    (
      Parser (..)
    , fromPure
    , fromEffect
    , die

    -- * Conversion
    , toParserK
    , fromParserK
    )
where

import Control.Applicative (Alternative(..), liftA2)
import Control.Exception (assert, Exception(..))
import Control.Monad (MonadPlus(..), ap)
import Control.Monad.Catch (MonadCatch, MonadThrow(..), try)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader.Class (MonadReader, ask, local)
import Control.Monad.State.Class (MonadState, get, put)
#if MIN_VERSION_base(4,9,0)
import qualified Control.Monad.Fail as Fail
#endif
#if !(MIN_VERSION_base(4,10,0))
import Data.Semigroup ((<>))
#endif
import Streamly.Internal.Control.Exception

import qualified Streamly.Internal.Data.Parser.ParserD.Type as D

-- | The parse driver result. The driver may stop with a final result, pause
-- with a continuation to resume, or fail with an error.
--
-- /Pre-release/
--
data Driver m a r =
      Stop !Int r
      -- XXX we can use a "resume" and a "stop" continuations instead of Maybe.
      -- measure if that works any better.
    | Partial !Int (Maybe a -> m (Driver m a r))
    | Continue !Int (Maybe a -> m (Driver m a r))
    | Failed String

instance Functor m => Functor (Driver m a) where
    fmap :: forall a b. (a -> b) -> Driver m a a -> Driver m a b
fmap a -> b
f (Stop Int
n a
r) = forall (m :: * -> *) a r. Int -> r -> Driver m a r
Stop Int
n (a -> b
f a
r)
    fmap a -> b
f (Partial Int
n Maybe a -> m (Driver m a a)
yld) = forall (m :: * -> *) a r.
Int -> (Maybe a -> m (Driver m a r)) -> Driver m a r
Partial Int
n (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> m (Driver m a a)
yld)
    fmap a -> b
f (Continue Int
n Maybe a -> m (Driver m a a)
yld) = forall (m :: * -> *) a r.
Int -> (Maybe a -> m (Driver m a r)) -> Driver m a r
Continue Int
n (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> m (Driver m a a)
yld)
    fmap a -> b
_ (Failed String
e) = forall (m :: * -> *) a r. String -> Driver m a r
Failed String
e

-- The parser's result.
--
-- /Pre-release/
--
data Parse b =
      Done !Int !b      -- Done, no more input needed
    | Error !String     -- Failed

instance Functor Parse where
    fmap :: forall a b. (a -> b) -> Parse a -> Parse b
fmap a -> b
f (Done Int
n a
b) = forall b. Int -> b -> Parse b
Done Int
n (a -> b
f a
b)
    fmap a -> b
_ (Error String
e) = forall b. String -> Parse b
Error String
e

-- | A continuation passing style parser representation.
newtype Parser m a b = MkParser
    { forall (m :: * -> *) a b.
Parser m a b
-> forall r.
   Int
   -> (Int, Int)
   -> ((Int, Int) -> Parse b -> m (Driver m a r))
   -> m (Driver m a r)
runParser :: forall r.
           -- The number of elements that were not used by the previous
           -- consumer and should be carried forward.
           Int
           -- (nesting level, used elem count). Nesting level is increased
           -- whenever we enter an Alternative composition and decreased when
           -- it is done. The used element count is a count of elements
           -- consumed by the Alternative. If the Alternative fails we need to
           -- backtrack by this amount.
           --
           -- The nesting level is used in parseDToK to optimize the case when
           -- we are not in an alternative, in that case we do not need to
           -- maintain the element count for backtracking.
        -> (Int, Int)
           -- The first argument is the (nest level, used count) tuple as
           -- described above. The leftover element count is carried as part of
           -- 'Done' constructor of 'Parse'.
        -> ((Int, Int) -> Parse b -> m (Driver m a r))
        -> m (Driver m a r)
    }

-------------------------------------------------------------------------------
-- Convert direct style 'D.Parser' to CPS style 'Parser'
-------------------------------------------------------------------------------

-- XXX Unlike the direct style folds/parsers, the initial action in CPS parsers
-- is not performed when the fold is initialized. It is performed when the
-- first element is processed by the fold or if no elements are processed then
-- at the extraction. We should either make the direct folds like this or make
-- the CPS folds behavior also like the direct ones.
--
-- | Convert a direct style parser ('D.Parser') to a CPS style parser
-- ('Parser').
--
{-# INLINE_NORMAL parseDToK #-}
parseDToK
    :: MonadCatch m
    => (s -> a -> m (D.Step s b))
    -> m (D.Initial s b)
    -> (s -> m b)
    -> Int
    -> (Int, Int)
    -> ((Int, Int) -> Parse b -> m (Driver m a r))
    -> m (Driver m a r)

parseDToK :: forall (m :: * -> *) s a b r.
MonadCatch m =>
(s -> a -> m (Step s b))
-> m (Initial s b)
-> (s -> m b)
-> Int
-> (Int, Int)
-> ((Int, Int) -> Parse b -> m (Driver m a r))
-> m (Driver m a r)
parseDToK s -> a -> m (Step s b)
pstep m (Initial s b)
initial s -> m b
extract Int
leftover (Int
0, Int
_) (Int, Int) -> Parse b -> m (Driver m a r)
cont = do
    Initial s b
res <- m (Initial s b)
initial
    case Initial s b
res of
        D.IPartial s
r -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a r.
Int -> (Maybe a -> m (Driver m a r)) -> Driver m a r
Continue Int
leftover (m s -> Maybe a -> m (Driver m a r)
parseCont (forall (m :: * -> *) a. Monad m => a -> m a
return s
r))
        D.IDone b
b -> (Int, Int) -> Parse b -> m (Driver m a r)
cont (Int
0,Int
0) (forall b. Int -> b -> Parse b
Done Int
0 b
b)
        D.IError String
err -> (Int, Int) -> Parse b -> m (Driver m a r)
cont (Int
0,Int
0) (forall b. String -> Parse b
Error String
err)

    where

    parseCont :: m s -> Maybe a -> m (Driver m a r)
parseCont m s
pst (Just a
x) = do
        s
r <- m s
pst
        Step s b
pRes <- s -> a -> m (Step s b)
pstep s
r a
x
        case Step s b
pRes of
            D.Done Int
n b
b -> (Int, Int) -> Parse b -> m (Driver m a r)
cont (Int
0,Int
0) (forall b. Int -> b -> Parse b
Done Int
n b
b)
            D.Error String
err -> (Int, Int) -> Parse b -> m (Driver m a r)
cont (Int
0,Int
0) (forall b. String -> Parse b
Error String
err)
            D.Partial Int
n s
pst1 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a r.
Int -> (Maybe a -> m (Driver m a r)) -> Driver m a r
Partial Int
n (m s -> Maybe a -> m (Driver m a r)
parseCont (forall (m :: * -> *) a. Monad m => a -> m a
return s
pst1))
            D.Continue Int
n s
pst1 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a r.
Int -> (Maybe a -> m (Driver m a r)) -> Driver m a r
Continue Int
n (m s -> Maybe a -> m (Driver m a r)
parseCont (forall (m :: * -> *) a. Monad m => a -> m a
return s
pst1))

    parseCont m s
acc Maybe a
Nothing = do
        s
pst <- m s
acc
        Either ParseError b
r <- forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ s -> m b
extract s
pst
        case Either ParseError b
r of
            Left (ParseError
e :: D.ParseError) -> (Int, Int) -> Parse b -> m (Driver m a r)
cont (Int
0,Int
0) (forall b. String -> Parse b
Error (forall e. Exception e => e -> String
displayException ParseError
e))
            Right b
b -> (Int, Int) -> Parse b -> m (Driver m a r)
cont (Int
0,Int
0) (forall b. Int -> b -> Parse b
Done Int
0 b
b)

parseDToK s -> a -> m (Step s b)
pstep m (Initial s b)
initial s -> m b
extract Int
leftover (Int
level, Int
count) (Int, Int) -> Parse b -> m (Driver m a r)
cont = do
    Initial s b
res <- m (Initial s b)
initial
    case Initial s b
res of
        D.IPartial s
r -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a r.
Int -> (Maybe a -> m (Driver m a r)) -> Driver m a r
Continue Int
leftover (Int -> m s -> Maybe a -> m (Driver m a r)
parseCont Int
count (forall (m :: * -> *) a. Monad m => a -> m a
return s
r))
        D.IDone b
b -> (Int, Int) -> Parse b -> m (Driver m a r)
cont (Int
level,Int
count) (forall b. Int -> b -> Parse b
Done Int
0 b
b)
        D.IError String
err -> (Int, Int) -> Parse b -> m (Driver m a r)
cont (Int
level,Int
count) (forall b. String -> Parse b
Error String
err)

    where

    parseCont :: Int -> m s -> Maybe a -> m (Driver m a r)
parseCont !Int
cnt m s
pst (Just a
x) = do
        let !cnt1 :: Int
cnt1 = Int
cnt forall a. Num a => a -> a -> a
+ Int
1
        s
r <- m s
pst
        Step s b
pRes <- s -> a -> m (Step s b)
pstep s
r a
x
        case Step s b
pRes of
            D.Done Int
n b
b -> do
                forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
n forall a. Ord a => a -> a -> Bool
<= Int
cnt1) (forall (m :: * -> *) a. Monad m => a -> m a
return ())
                (Int, Int) -> Parse b -> m (Driver m a r)
cont (Int
level, Int
cnt1 forall a. Num a => a -> a -> a
- Int
n) (forall b. Int -> b -> Parse b
Done Int
n b
b)
            D.Error String
err ->
                (Int, Int) -> Parse b -> m (Driver m a r)
cont (Int
level, Int
cnt1) (forall b. String -> Parse b
Error String
err)
            D.Partial Int
n s
pst1 -> do
                forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
n forall a. Ord a => a -> a -> Bool
<= Int
cnt1) (forall (m :: * -> *) a. Monad m => a -> m a
return ())
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a r.
Int -> (Maybe a -> m (Driver m a r)) -> Driver m a r
Partial Int
n (Int -> m s -> Maybe a -> m (Driver m a r)
parseCont (Int
cnt1 forall a. Num a => a -> a -> a
- Int
n) (forall (m :: * -> *) a. Monad m => a -> m a
return s
pst1))
            D.Continue Int
n s
pst1 -> do
                forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
n forall a. Ord a => a -> a -> Bool
<= Int
cnt1) (forall (m :: * -> *) a. Monad m => a -> m a
return ())
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a r.
Int -> (Maybe a -> m (Driver m a r)) -> Driver m a r
Continue Int
n (Int -> m s -> Maybe a -> m (Driver m a r)
parseCont (Int
cnt1 forall a. Num a => a -> a -> a
- Int
n) (forall (m :: * -> *) a. Monad m => a -> m a
return s
pst1))
    parseCont Int
cnt m s
acc Maybe a
Nothing = do
        s
pst <- m s
acc
        Either ParseError b
r <- forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ s -> m b
extract s
pst
        let s :: (Int, Int)
s = (Int
level, Int
cnt)
        case Either ParseError b
r of
            Left (ParseError
e :: D.ParseError) -> (Int, Int) -> Parse b -> m (Driver m a r)
cont (Int, Int)
s (forall b. String -> Parse b
Error (forall e. Exception e => e -> String
displayException ParseError
e))
            Right b
b -> (Int, Int) -> Parse b -> m (Driver m a r)
cont (Int, Int)
s (forall b. Int -> b -> Parse b
Done Int
0 b
b)

-- | Convert a direct style 'D.Parser' to a CPS style 'Parser'.
--
-- /Pre-release/
--
{-# INLINE_LATE toParserK #-}
toParserK :: MonadCatch m => D.Parser m a b -> Parser m a b
toParserK :: forall (m :: * -> *) a b.
MonadCatch m =>
Parser m a b -> Parser m a b
toParserK (D.Parser s -> a -> m (Step s b)
step m (Initial s b)
initial s -> m b
extract) =
    forall (m :: * -> *) a b.
(forall r.
 Int
 -> (Int, Int)
 -> ((Int, Int) -> Parse b -> m (Driver m a r))
 -> m (Driver m a r))
-> Parser m a b
MkParser forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s a b r.
MonadCatch m =>
(s -> a -> m (Step s b))
-> m (Initial s b)
-> (s -> m b)
-> Int
-> (Int, Int)
-> ((Int, Int) -> Parse b -> m (Driver m a r))
-> m (Driver m a r)
parseDToK s -> a -> m (Step s b)
step m (Initial s b)
initial s -> m b
extract

-------------------------------------------------------------------------------
-- Convert CPS style 'Parser' to direct style 'D.Parser'
-------------------------------------------------------------------------------

-- | A continuation to extract the result when a CPS parser is done.
{-# INLINE parserDone #-}
parserDone :: Monad m => (Int, Int) -> Parse b -> m (Driver m a b)
parserDone :: forall (m :: * -> *) b a.
Monad m =>
(Int, Int) -> Parse b -> m (Driver m a b)
parserDone (Int
0,Int
_) (Done Int
n b
b) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a r. Int -> r -> Driver m a r
Stop Int
n b
b
parserDone (Int, Int)
st (Done Int
_ b
_) =
    forall a. (?callStack::CallStack) => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Bug: fromParserK: inside alternative: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Int, Int)
st
parserDone (Int, Int)
_ (Error String
e) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a r. String -> Driver m a r
Failed String
e

-- | When there is no more input to feed, extract the result from the Parser.
--
-- /Pre-release/
--
extractParse :: MonadThrow m => (Maybe a -> m (Driver m a b)) -> m b
extractParse :: forall (m :: * -> *) a b.
MonadThrow m =>
(Maybe a -> m (Driver m a b)) -> m b
extractParse Maybe a -> m (Driver m a b)
cont = do
    Driver m a b
r <- Maybe a -> m (Driver m a b)
cont forall a. Maybe a
Nothing
    case Driver m a b
r of
        Stop Int
_ b
b -> forall (m :: * -> *) a. Monad m => a -> m a
return b
b
        Partial Int
_ Maybe a -> m (Driver m a b)
_ -> forall a. (?callStack::CallStack) => String -> a
error String
"Bug: extractParse got Partial"
        Continue Int
_ Maybe a -> m (Driver m a b)
cont1 -> forall (m :: * -> *) a b.
MonadThrow m =>
(Maybe a -> m (Driver m a b)) -> m b
extractParse Maybe a -> m (Driver m a b)
cont1
        Failed String
e -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> ParseError
D.ParseError String
e

data FromParserK b c = FPKDone !Int !b | FPKCont c

-- | Convert a CPS style 'Parser' to a direct style 'D.Parser'.
--
-- "initial" returns a continuation which can be called one input at a time
-- using the "step" function.
--
-- /Pre-release/
--
{-# INLINE_LATE fromParserK #-}
fromParserK :: MonadThrow m => Parser m a b -> D.Parser m a b
fromParserK :: forall (m :: * -> *) a b.
MonadThrow m =>
Parser m a b -> Parser m a b
fromParserK Parser m a b
parser = forall (m :: * -> *) a b s.
(s -> a -> m (Step s b))
-> m (Initial s b) -> (s -> m b) -> Parser m a b
D.Parser forall {m :: * -> *} {b} {a} {m :: * -> *} {a} {b}.
Monad m =>
FromParserK b (Maybe a -> m (Driver m a b))
-> a -> m (Step (FromParserK b (Maybe a -> m (Driver m a b))) b)
step forall {b}.
m (Initial (FromParserK b (Maybe a -> m (Driver m a b))) b)
initial forall {m :: * -> *} {a} {a}.
MonadThrow m =>
FromParserK a (Maybe a -> m (Driver m a a)) -> m a
extract

    where

    initial :: m (Initial (FromParserK b (Maybe a -> m (Driver m a b))) b)
initial = do
        Driver m a b
r <- forall (m :: * -> *) a b.
Parser m a b
-> forall r.
   Int
   -> (Int, Int)
   -> ((Int, Int) -> Parse b -> m (Driver m a r))
   -> m (Driver m a r)
runParser Parser m a b
parser Int
0 (Int
0,Int
0) forall (m :: * -> *) b a.
Monad m =>
(Int, Int) -> Parse b -> m (Driver m a b)
parserDone
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Driver m a b
r of
            Stop Int
n b
b -> forall s b. s -> Initial s b
D.IPartial forall a b. (a -> b) -> a -> b
$ forall b c. Int -> b -> FromParserK b c
FPKDone Int
n b
b
            Failed String
e -> forall s b. String -> Initial s b
D.IError String
e
            Partial Int
_ Maybe a -> m (Driver m a b)
cont -> forall s b. s -> Initial s b
D.IPartial forall a b. (a -> b) -> a -> b
$ forall b c. c -> FromParserK b c
FPKCont Maybe a -> m (Driver m a b)
cont -- XXX can we get this?
            Continue Int
_ Maybe a -> m (Driver m a b)
cont -> forall s b. s -> Initial s b
D.IPartial forall a b. (a -> b) -> a -> b
$ forall b c. c -> FromParserK b c
FPKCont Maybe a -> m (Driver m a b)
cont

    -- Note, we can only reach FPKDone and FPKError from "initial". FPKCont
    -- always transitions to only FPKCont.  The input remains unconsumed in
    -- this case so we use "n + 1".
    step :: FromParserK b (Maybe a -> m (Driver m a b))
-> a -> m (Step (FromParserK b (Maybe a -> m (Driver m a b))) b)
step (FPKDone Int
n b
b) a
_ = do
        forall (f :: * -> *). Applicative f => Bool -> f ()
assertM (Int
n forall a. Eq a => a -> a -> Bool
== Int
0)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s b. Int -> b -> Step s b
D.Done (Int
n forall a. Num a => a -> a -> a
+ Int
1) b
b
    step (FPKCont Maybe a -> m (Driver m a b)
cont) a
a = do
        Driver m a b
r <- Maybe a -> m (Driver m a b)
cont (forall a. a -> Maybe a
Just a
a)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Driver m a b
r of
            Stop Int
n b
b -> forall s b. Int -> b -> Step s b
D.Done Int
n b
b
            Failed String
e -> forall s b. String -> Step s b
D.Error String
e
            Partial Int
n Maybe a -> m (Driver m a b)
cont1 -> forall s b. Int -> s -> Step s b
D.Partial Int
n (forall b c. c -> FromParserK b c
FPKCont Maybe a -> m (Driver m a b)
cont1)
            Continue Int
n Maybe a -> m (Driver m a b)
cont1 -> forall s b. Int -> s -> Step s b
D.Continue Int
n (forall b c. c -> FromParserK b c
FPKCont Maybe a -> m (Driver m a b)
cont1)

    -- Note, we can only reach FPKDone and FPKError from "initial".
    extract :: FromParserK a (Maybe a -> m (Driver m a a)) -> m a
extract (FPKDone Int
_ a
b) = forall (m :: * -> *) a. Monad m => a -> m a
return a
b
    extract (FPKCont Maybe a -> m (Driver m a a)
cont) = forall (m :: * -> *) a b.
MonadThrow m =>
(Maybe a -> m (Driver m a b)) -> m b
extractParse Maybe a -> m (Driver m a a)
cont

#ifndef DISABLE_FUSION
{-# RULES "fromParserK/toParserK fusion" [2]
    forall s. toParserK (fromParserK s) = s #-}
{-# RULES "toParserK/fromParserK fusion" [2]
    forall s. fromParserK (toParserK s) = s #-}
#endif

-------------------------------------------------------------------------------
-- Functor
-------------------------------------------------------------------------------

-- | Maps a function over the output of the parser.
--
instance Functor m => Functor (Parser m a) where
    {-# INLINE fmap #-}
    fmap :: forall a b. (a -> b) -> Parser m a a -> Parser m a b
fmap a -> b
f Parser m a a
parser = forall (m :: * -> *) a b.
(forall r.
 Int
 -> (Int, Int)
 -> ((Int, Int) -> Parse b -> m (Driver m a r))
 -> m (Driver m a r))
-> Parser m a b
MkParser forall a b. (a -> b) -> a -> b
$ \Int
lo (Int, Int)
st (Int, Int) -> Parse b -> m (Driver m a r)
yieldk ->
        let yld :: (Int, Int) -> Parse a -> m (Driver m a r)
yld (Int, Int)
s Parse a
res = (Int, Int) -> Parse b -> m (Driver m a r)
yieldk (Int, Int)
s (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Parse a
res)
         in forall (m :: * -> *) a b.
Parser m a b
-> forall r.
   Int
   -> (Int, Int)
   -> ((Int, Int) -> Parse b -> m (Driver m a r))
   -> m (Driver m a r)
runParser Parser m a a
parser Int
lo (Int, Int)
st (Int, Int) -> Parse a -> m (Driver m a r)
yld

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

-- This is the dual of stream "fromPure".
--
-- | A parser that always yields a pure value without consuming any input.
--
-- /Pre-release/
--
{-# INLINE fromPure #-}
fromPure :: b -> Parser m a b
fromPure :: forall b (m :: * -> *) a. b -> Parser m a b
fromPure b
b = forall (m :: * -> *) a b.
(forall r.
 Int
 -> (Int, Int)
 -> ((Int, Int) -> Parse b -> m (Driver m a r))
 -> m (Driver m a r))
-> Parser m a b
MkParser forall a b. (a -> b) -> a -> b
$ \Int
lo (Int, Int)
st (Int, Int) -> Parse b -> m (Driver m a r)
yieldk -> (Int, Int) -> Parse b -> m (Driver m a r)
yieldk (Int, Int)
st (forall b. Int -> b -> Parse b
Done Int
lo b
b)

-- | See 'Streamly.Internal.Data.Parser.fromEffect'.
--
-- /Pre-release/
--
{-# INLINE fromEffect #-}
fromEffect :: Monad m => m b -> Parser m a b
fromEffect :: forall (m :: * -> *) b a. Monad m => m b -> Parser m a b
fromEffect m b
eff = forall (m :: * -> *) a b.
(forall r.
 Int
 -> (Int, Int)
 -> ((Int, Int) -> Parse b -> m (Driver m a r))
 -> m (Driver m a r))
-> Parser m a b
MkParser forall a b. (a -> b) -> a -> b
$ \Int
lo (Int, Int)
st (Int, Int) -> Parse b -> m (Driver m a r)
yieldk -> m b
eff forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b
b -> (Int, Int) -> Parse b -> m (Driver m a r)
yieldk (Int, Int)
st (forall b. Int -> b -> Parse b
Done Int
lo b
b)

-- | 'Applicative' form of 'Streamly.Internal.Data.Parser.serialWith'. Note that
-- this operation does not fuse, use 'Streamly.Internal.Data.Parser.serialWith'
-- when fusion is important.
--
instance Monad m => Applicative (Parser m a) where
    {-# INLINE pure #-}
    pure :: forall a. a -> Parser m a a
pure = forall b (m :: * -> *) a. b -> Parser m a b
fromPure

    {-# INLINE (<*>) #-}
    <*> :: forall a b. Parser m a (a -> b) -> Parser m a a -> Parser m a b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

    {-# INLINE (*>) #-}
    Parser m a a
m1 *> :: forall a b. Parser m a a -> Parser m a b -> Parser m a b
*> Parser m a b
m2 = forall (m :: * -> *) a b.
(forall r.
 Int
 -> (Int, Int)
 -> ((Int, Int) -> Parse b -> m (Driver m a r))
 -> m (Driver m a r))
-> Parser m a b
MkParser forall a b. (a -> b) -> a -> b
$ \Int
lo (Int, Int)
st (Int, Int) -> Parse b -> m (Driver m a r)
yieldk ->
        let yield1 :: (Int, Int) -> Parse b -> m (Driver m a r)
yield1 (Int, Int)
s (Done Int
n b
_) = forall (m :: * -> *) a b.
Parser m a b
-> forall r.
   Int
   -> (Int, Int)
   -> ((Int, Int) -> Parse b -> m (Driver m a r))
   -> m (Driver m a r)
runParser Parser m a b
m2 Int
n (Int, Int)
s (Int, Int) -> Parse b -> m (Driver m a r)
yieldk
            yield1 (Int, Int)
s (Error String
e) = (Int, Int) -> Parse b -> m (Driver m a r)
yieldk (Int, Int)
s (forall b. String -> Parse b
Error String
e)
        in forall (m :: * -> *) a b.
Parser m a b
-> forall r.
   Int
   -> (Int, Int)
   -> ((Int, Int) -> Parse b -> m (Driver m a r))
   -> m (Driver m a r)
runParser Parser m a a
m1 Int
lo (Int, Int)
st forall {b}. (Int, Int) -> Parse b -> m (Driver m a r)
yield1

    {-# INLINE (<*) #-}
    Parser m a a
m1 <* :: forall a b. Parser m a a -> Parser m a b -> Parser m a a
<* Parser m a b
m2 = forall (m :: * -> *) a b.
(forall r.
 Int
 -> (Int, Int)
 -> ((Int, Int) -> Parse b -> m (Driver m a r))
 -> m (Driver m a r))
-> Parser m a b
MkParser forall a b. (a -> b) -> a -> b
$ \Int
lo (Int, Int)
st (Int, Int) -> Parse a -> m (Driver m a r)
yieldk ->
        let yield1 :: (Int, Int) -> Parse a -> m (Driver m a r)
yield1 (Int, Int)
s (Done Int
n a
b) =
                let yield2 :: (Int, Int) -> Parse b -> m (Driver m a r)
yield2 (Int, Int)
s1 (Done Int
n1 b
_) = (Int, Int) -> Parse a -> m (Driver m a r)
yieldk (Int, Int)
s1 (forall b. Int -> b -> Parse b
Done Int
n1 a
b)
                    yield2 (Int, Int)
s1 (Error String
e) = (Int, Int) -> Parse a -> m (Driver m a r)
yieldk (Int, Int)
s1 (forall b. String -> Parse b
Error String
e)
                in forall (m :: * -> *) a b.
Parser m a b
-> forall r.
   Int
   -> (Int, Int)
   -> ((Int, Int) -> Parse b -> m (Driver m a r))
   -> m (Driver m a r)
runParser Parser m a b
m2 Int
n (Int, Int)
s forall {b}. (Int, Int) -> Parse b -> m (Driver m a r)
yield2
            yield1 (Int, Int)
s (Error String
e) = (Int, Int) -> Parse a -> m (Driver m a r)
yieldk (Int, Int)
s (forall b. String -> Parse b
Error String
e)
        in forall (m :: * -> *) a b.
Parser m a b
-> forall r.
   Int
   -> (Int, Int)
   -> ((Int, Int) -> Parse b -> m (Driver m a r))
   -> m (Driver m a r)
runParser Parser m a a
m1 Int
lo (Int, Int)
st (Int, Int) -> Parse a -> m (Driver m a r)
yield1

#if MIN_VERSION_base(4,10,0)
    {-# INLINE liftA2 #-}
    liftA2 :: forall a b c.
(a -> b -> c) -> Parser m a a -> Parser m a b -> Parser m a c
liftA2 a -> b -> c
f Parser m a a
x = forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b -> c
f Parser m a a
x)
#endif

-------------------------------------------------------------------------------
-- Monad
-------------------------------------------------------------------------------

-- This is the dual of "nil".
--
-- | A parser that always fails with an error message without consuming
-- any input.
--
-- /Pre-release/
--
{-# INLINE die #-}
die :: String -> Parser m a b
die :: forall (m :: * -> *) a b. String -> Parser m a b
die String
err = forall (m :: * -> *) a b.
(forall r.
 Int
 -> (Int, Int)
 -> ((Int, Int) -> Parse b -> m (Driver m a r))
 -> m (Driver m a r))
-> Parser m a b
MkParser (\Int
_ (Int, Int)
st (Int, Int) -> Parse b -> m (Driver m a r)
yieldk -> (Int, Int) -> Parse b -> m (Driver m a r)
yieldk (Int, Int)
st (forall b. String -> Parse b
Error String
err))

-- | 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]
-- @
--
-- See also 'Streamly.Internal.Data.Parser.concatMap'. This monad instance
-- does not fuse, use 'Streamly.Internal.Data.Parser.concatMap' when you need
-- fusion.
--
instance Monad m => Monad (Parser m a) where
    {-# INLINE return #-}
    return :: forall a. a -> Parser m a a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure

    {-# INLINE (>>=) #-}
    Parser m a a
m >>= :: forall a b. Parser m a a -> (a -> Parser m a b) -> Parser m a b
>>= a -> Parser m a b
k = forall (m :: * -> *) a b.
(forall r.
 Int
 -> (Int, Int)
 -> ((Int, Int) -> Parse b -> m (Driver m a r))
 -> m (Driver m a r))
-> Parser m a b
MkParser forall a b. (a -> b) -> a -> b
$ \Int
lo (Int, Int)
st (Int, Int) -> Parse b -> m (Driver m a r)
yieldk ->
        let yield1 :: (Int, Int) -> Parse a -> m (Driver m a r)
yield1 (Int, Int)
s (Done Int
n a
b) = forall (m :: * -> *) a b.
Parser m a b
-> forall r.
   Int
   -> (Int, Int)
   -> ((Int, Int) -> Parse b -> m (Driver m a r))
   -> m (Driver m a r)
runParser (a -> Parser m a b
k a
b) Int
n (Int, Int)
s (Int, Int) -> Parse b -> m (Driver m a r)
yieldk
            yield1 (Int, Int)
s (Error String
e) = (Int, Int) -> Parse b -> m (Driver m a r)
yieldk (Int, Int)
s (forall b. String -> Parse b
Error String
e)
         in forall (m :: * -> *) a b.
Parser m a b
-> forall r.
   Int
   -> (Int, Int)
   -> ((Int, Int) -> Parse b -> m (Driver m a r))
   -> m (Driver m a r)
runParser Parser m a a
m Int
lo (Int, Int)
st (Int, Int) -> Parse a -> m (Driver m a r)
yield1

    {-# INLINE (>>) #-}
    >> :: forall a b. Parser m a a -> Parser m a b -> Parser m a b
(>>) = forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)

#if !(MIN_VERSION_base(4,13,0))
    -- This is redefined instead of just being Fail.fail to be
    -- compatible with base 4.8.
    {-# INLINE fail #-}
    fail = die
#endif

#if MIN_VERSION_base(4,9,0)
instance Monad m => Fail.MonadFail (Parser m a) where
    {-# INLINE fail #-}
    fail :: forall a. String -> Parser m a a
fail = forall (m :: * -> *) a b. String -> Parser m a b
die
#endif

instance (MonadThrow m, MonadReader r m, MonadCatch m) => MonadReader r (Parser m a) where
    {-# INLINE ask #-}
    ask :: Parser m a r
ask = forall (m :: * -> *) b a. Monad m => m b -> Parser m a b
fromEffect forall r (m :: * -> *). MonadReader r m => m r
ask
    {-# INLINE local #-}
    local :: forall a. (r -> r) -> Parser m a a -> Parser m a a
local r -> r
f (forall (m :: * -> *) a b.
MonadThrow m =>
Parser m a b -> Parser m a b
fromParserK -> Parser m a a
dp) =
      forall (m :: * -> *) a b.
MonadCatch m =>
Parser m a b -> Parser m a b
toParserK forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local r -> r
f Parser m a a
dp


instance (MonadThrow m, MonadState s m) => MonadState s (Parser m a) where
    {-# INLINE get #-}
    get :: Parser m a s
get = forall (m :: * -> *) b a. Monad m => m b -> Parser m a b
fromEffect forall s (m :: * -> *). MonadState s m => m s
get
    {-# INLINE put #-}
    put :: s -> Parser m a ()
put = forall (m :: * -> *) b a. Monad m => m b -> Parser m a b
fromEffect forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *). MonadState s m => s -> m ()
put


instance (MonadThrow m, MonadIO m) => MonadIO (Parser m a) where
    {-# INLINE liftIO #-}
    liftIO :: forall a. IO a -> Parser m a a
liftIO = forall (m :: * -> *) b a. Monad m => m b -> Parser m a b
fromEffect forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

-------------------------------------------------------------------------------
-- Alternative
-------------------------------------------------------------------------------

-- | 'Alternative' form of 'Streamly.Internal.Data.Parser.alt'. Backtrack and
-- run the second parser if the first one fails.
--
-- The "some" and "many" operations of alternative accumulate results in a pure
-- list which is not scalable and streaming. Instead use
-- 'Streamly.Internal.Data.Parser.some' and
-- 'Streamly.Internal.Data.Parser.many' for fusible operations with composable
-- accumulation of results.
--
-- See also 'Streamly.Internal.Data.Parser.alt'. This 'Alternative' instance
-- does not fuse, use 'Streamly.Internal.Data.Parser.alt' when you need
-- fusion.
--
instance Monad m => Alternative (Parser m a) where
    {-# INLINE empty #-}
    empty :: forall a. Parser m a a
empty = forall (m :: * -> *) a b. String -> Parser m a b
die String
"empty"

    {-# INLINE (<|>) #-}
    Parser m a a
m1 <|> :: forall a. Parser m a a -> Parser m a a -> Parser m a a
<|> Parser m a a
m2 = forall (m :: * -> *) a b.
(forall r.
 Int
 -> (Int, Int)
 -> ((Int, Int) -> Parse b -> m (Driver m a r))
 -> m (Driver m a r))
-> Parser m a b
MkParser forall a b. (a -> b) -> a -> b
$ \Int
lo (Int
level, Int
_) (Int, Int) -> Parse a -> m (Driver m a r)
yieldk ->
        let yield1 :: (Int, Int) -> Parse a -> m (Driver m a r)
yield1 (Int
0, Int
_) Parse a
_ = forall a. (?callStack::CallStack) => String -> a
error String
"0 nest level in Alternative"
            yield1 (Int
lvl, Int
_) (Done Int
n a
b) = (Int, Int) -> Parse a -> m (Driver m a r)
yieldk (Int
lvl forall a. Num a => a -> a -> a
- Int
1, Int
0) (forall b. Int -> b -> Parse b
Done Int
n a
b)
            yield1 (Int
lvl, Int
cnt) (Error String
_) = forall (m :: * -> *) a b.
Parser m a b
-> forall r.
   Int
   -> (Int, Int)
   -> ((Int, Int) -> Parse b -> m (Driver m a r))
   -> m (Driver m a r)
runParser Parser m a a
m2 Int
cnt (Int
lvl forall a. Num a => a -> a -> a
- Int
1, Int
0) (Int, Int) -> Parse a -> m (Driver m a r)
yieldk
        in forall (m :: * -> *) a b.
Parser m a b
-> forall r.
   Int
   -> (Int, Int)
   -> ((Int, Int) -> Parse b -> m (Driver m a r))
   -> m (Driver m a r)
runParser Parser m a a
m1 Int
lo (Int
level forall a. Num a => a -> a -> a
+ Int
1, Int
0) (Int, Int) -> Parse a -> m (Driver m a r)
yield1

    -- some and many are implemented here instead of using default definitions
    -- so that we can use INLINE on them. It gives 50% performance improvement.

    {-# INLINE many #-}
    many :: forall a. Parser m a a -> Parser m a [a]
many Parser m a a
v = Parser m a [a]
many_v

        where

        many_v :: Parser m a [a]
many_v = Parser m a [a]
some_v forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        some_v :: Parser m a [a]
some_v = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser m a a
v forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser m a [a]
many_v

    {-# INLINE some #-}
    some :: forall a. Parser m a a -> Parser m a [a]
some Parser m a a
v = Parser m a [a]
some_v

        where

        many_v :: Parser m a [a]
many_v = Parser m a [a]
some_v forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        some_v :: Parser m a [a]
some_v = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser m a a
v forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser m a [a]
many_v

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

    {-# INLINE mplus #-}
    mplus :: forall a. Parser m a a -> Parser m a a -> Parser m a a
mplus = forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)