{-# LANGUAGE Rank2Types #-}

-- | 'ParserT' is the core monad transformer for parsing.
module SimpleParser.Parser
  ( ParserT (..)
  , Parser
  , runParser
  , pureParser
  , bindParser
  , failParser
  , liftParser
  , hoistParser
  , catchJustParser
  , throwParser
  , catchParser
  , emptyParser
  , orParser
  , greedyStarParser
  , greedyStarParser_
  , greedyPlusParser
  , greedyPlusParser_
  , defaultParser
  , optionalParser
  , reflectParser
  , silenceParser
  , lookAheadParser
  , markParser
  , markWithStateParser
  , markWithOptStateParser
  , unmarkParser
  , commitParser
  , onEmptyParser
  ) where

import Control.Applicative (Alternative (..), liftA2)
import Control.Monad (MonadPlus (..), ap, (>=>))
import Control.Monad.Except (MonadError (..))
import Control.Monad.Identity (Identity (..))
import Control.Monad.Morph (MFunctor (..))
import Control.Monad.State (MonadState (..))
import Control.Monad.Trans (MonadTrans (..))
import Data.Bifunctor (first)
import Data.Sequence (Seq (..))
import Data.Sequence.NonEmpty ((><|))
import qualified Data.Sequence.NonEmpty as NESeq
import Data.Text (Text)
import qualified Data.Text as T
import SimpleParser.Chunked (Chunked (..))
import SimpleParser.Result (CompoundError (..), Mark (..), ParseError (..), ParseErrorBundle (..), ParseResult (..),
                            ParseSuccess (..), markParseError, parseErrorResume, unmarkParseError)
import SimpleParser.Stack (emptyStack)

-- | A 'ParserT' is a state/error/list transformer useful for parsing.
-- All MTL instances are for this transformer only. If, for example, your effect
-- has its own 'MonadState' instance, you'll have to use 'lift get' instead of 'get'.
newtype ParserT l s e m a = ParserT { forall l s e (m :: * -> *) a.
ParserT l s e m a -> s -> m (Maybe (ParseResult l s e a))
runParserT :: s -> m (Maybe (ParseResult l s e a)) }
  deriving (forall a b. a -> ParserT l s e m b -> ParserT l s e m a
forall a b. (a -> b) -> ParserT l s e m a -> ParserT l s e m b
forall l s e (m :: * -> *) a b.
Functor m =>
a -> ParserT l s e m b -> ParserT l s e m a
forall l s e (m :: * -> *) a b.
Functor m =>
(a -> b) -> ParserT l s e m a -> ParserT l s e m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ParserT l s e m b -> ParserT l s e m a
$c<$ :: forall l s e (m :: * -> *) a b.
Functor m =>
a -> ParserT l s e m b -> ParserT l s e m a
fmap :: forall a b. (a -> b) -> ParserT l s e m a -> ParserT l s e m b
$cfmap :: forall l s e (m :: * -> *) a b.
Functor m =>
(a -> b) -> ParserT l s e m a -> ParserT l s e m b
Functor)

-- | Use 'Parser' if you have no need for other monadic effects.
type Parser l s e a = ParserT l s e Identity a

-- | Runs a non-effectful parser from an inital state and collects all results.
runParser :: Parser l s e a -> s -> Maybe (ParseResult l s e a)
runParser :: forall l s e a. Parser l s e a -> s -> Maybe (ParseResult l s e a)
runParser Parser l s e a
parser s
s = forall a. Identity a -> a
runIdentity (forall l s e (m :: * -> *) a.
ParserT l s e m a -> s -> m (Maybe (ParseResult l s e a))
runParserT Parser l s e a
parser s
s)

-- | Applicative pure
pureParser :: Monad m => a -> ParserT l s e m a
pureParser :: forall (m :: * -> *) a l s e. Monad m => a -> ParserT l s e m a
pureParser a
a = forall l s e (m :: * -> *) a.
(s -> m (Maybe (ParseResult l s e a))) -> ParserT l s e m a
ParserT (\s
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (forall l s e a. ParseSuccess s a -> ParseResult l s e a
ParseResultSuccess (forall s a. s -> a -> ParseSuccess s a
ParseSuccess s
s a
a))))

instance Monad m => Applicative (ParserT l s e m) where
  pure :: forall a. a -> ParserT l s e m a
pure = forall (m :: * -> *) a l s e. Monad m => a -> ParserT l s e m a
pureParser
  <*> :: forall a b.
ParserT l s e m (a -> b) -> ParserT l s e m a -> ParserT l s e m b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

-- | Monadic bind
bindParser :: Monad m => ParserT l s e m a -> (a -> ParserT l s e m b) -> ParserT l s e m b
bindParser :: forall (m :: * -> *) l s e a b.
Monad m =>
ParserT l s e m a -> (a -> ParserT l s e m b) -> ParserT l s e m b
bindParser ParserT l s e m a
parser a -> ParserT l s e m b
f = forall l s e (m :: * -> *) a.
(s -> m (Maybe (ParseResult l s e a))) -> ParserT l s e m a
ParserT (forall l s e (m :: * -> *) a.
ParserT l s e m a -> s -> m (Maybe (ParseResult l s e a))
runParserT ParserT l s e m a
parser forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Maybe (ParseResult l s e a) -> m (Maybe (ParseResult l s e b))
go) where
  go :: Maybe (ParseResult l s e a) -> m (Maybe (ParseResult l s e b))
go Maybe (ParseResult l s e a)
mres =
    case Maybe (ParseResult l s e a)
mres of
      Maybe (ParseResult l s e a)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      Just ParseResult l s e a
res ->
          case ParseResult l s e a
res of
            ParseResultError ParseErrorBundle l s e
errs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (forall l s e a. ParseErrorBundle l s e -> ParseResult l s e a
ParseResultError ParseErrorBundle l s e
errs))
            ParseResultSuccess (ParseSuccess s
t a
a) -> forall l s e (m :: * -> *) a.
ParserT l s e m a -> s -> m (Maybe (ParseResult l s e a))
runParserT (a -> ParserT l s e m b
f a
a) s
t

instance Monad m => Monad (ParserT l s e m) where
  return :: forall a. a -> ParserT l s e m a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  >>= :: forall a b.
ParserT l s e m a -> (a -> ParserT l s e m b) -> ParserT l s e m b
(>>=) = forall (m :: * -> *) l s e a b.
Monad m =>
ParserT l s e m a -> (a -> ParserT l s e m b) -> ParserT l s e m b
bindParser

-- | The empty parser
emptyParser :: Monad m => ParserT l s e m a
emptyParser :: forall (m :: * -> *) l s e a. Monad m => ParserT l s e m a
emptyParser = forall l s e (m :: * -> *) a.
(s -> m (Maybe (ParseResult l s e a))) -> ParserT l s e m a
ParserT (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing))

-- | Yields from the first parser of the two that returns a successfull result.
-- Otherwise will merge and yield all errors.
orParser :: Monad m => ParserT l s e m a -> ParserT l s e m a -> ParserT l s e m a
orParser :: forall (m :: * -> *) l s e a.
Monad m =>
ParserT l s e m a -> ParserT l s e m a -> ParserT l s e m a
orParser ParserT l s e m a
one ParserT l s e m a
two = forall l s e (m :: * -> *) a.
(s -> m (Maybe (ParseResult l s e a))) -> ParserT l s e m a
ParserT (\s
s -> forall l s e (m :: * -> *) a.
ParserT l s e m a -> s -> m (Maybe (ParseResult l s e a))
runParserT ParserT l s e m a
one s
s forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> Maybe (ParseResult l s e a) -> m (Maybe (ParseResult l s e a))
go1 s
s) where
  go1 :: s -> Maybe (ParseResult l s e a) -> m (Maybe (ParseResult l s e a))
go1 s
s Maybe (ParseResult l s e a)
mres1 =
    case Maybe (ParseResult l s e a)
mres1 of
      Maybe (ParseResult l s e a)
Nothing -> forall l s e (m :: * -> *) a.
ParserT l s e m a -> s -> m (Maybe (ParseResult l s e a))
runParserT ParserT l s e m a
two s
s forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {f :: * -> *} {l} {s} {e} {a}.
Applicative f =>
Seq (ParseError l s e)
-> Maybe (ParseResult l s e a) -> f (Maybe (ParseResult l s e a))
go2 forall (f :: * -> *) a. Alternative f => f a
empty
      Just ParseResult l s e a
res1 ->
        case ParseResult l s e a
res1 of
          ParseResultSuccess ParseSuccess s a
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ParseResult l s e a)
mres1
          ParseResultError (ParseErrorBundle NESeq (ParseError l s e)
es1) -> forall l s e (m :: * -> *) a.
ParserT l s e m a -> s -> m (Maybe (ParseResult l s e a))
runParserT ParserT l s e m a
two s
s forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {f :: * -> *} {l} {s} {e} {a}.
Applicative f =>
Seq (ParseError l s e)
-> Maybe (ParseResult l s e a) -> f (Maybe (ParseResult l s e a))
go2 (forall a. NESeq a -> Seq a
NESeq.toSeq NESeq (ParseError l s e)
es1)

  go2 :: Seq (ParseError l s e)
-> Maybe (ParseResult l s e a) -> f (Maybe (ParseResult l s e a))
go2 Seq (ParseError l s e)
es1 Maybe (ParseResult l s e a)
mres2 =
    case Maybe (ParseResult l s e a)
mres2 of
      Maybe (ParseResult l s e a)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l s e a. ParseErrorBundle l s e -> ParseResult l s e a
ParseResultError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l s e. NESeq (ParseError l s e) -> ParseErrorBundle l s e
ParseErrorBundle) (forall a. Seq a -> Maybe (NESeq a)
NESeq.nonEmptySeq Seq (ParseError l s e)
es1))
      Just ParseResult l s e a
res2 ->
        case ParseResult l s e a
res2 of
          ParseResultSuccess ParseSuccess s a
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ParseResult l s e a)
mres2
          ParseResultError (ParseErrorBundle NESeq (ParseError l s e)
es2) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (forall l s e a. ParseErrorBundle l s e -> ParseResult l s e a
ParseResultError (forall l s e. NESeq (ParseError l s e) -> ParseErrorBundle l s e
ParseErrorBundle (Seq (ParseError l s e)
es1 forall a. Seq a -> NESeq a -> NESeq a
><| NESeq (ParseError l s e)
es2))))

-- | Yields the LONGEST string of 0 or more successes of the given parser.
-- Failures will be silenced.
greedyStarParser :: (Chunked seq elem, Monad m) => ParserT l s e m elem -> ParserT l s e m seq
greedyStarParser :: forall seq elem (m :: * -> *) l s e.
(Chunked seq elem, Monad m) =>
ParserT l s e m elem -> ParserT l s e m seq
greedyStarParser ParserT l s e m elem
parser = [elem] -> ParserT l s e m seq
go [] where
  opt :: ParserT l s e m (Maybe elem)
opt = forall (m :: * -> *) l s e a.
Monad m =>
ParserT l s e m a -> ParserT l s e m (Maybe a)
optionalParser ParserT l s e m elem
parser
  go :: [elem] -> ParserT l s e m seq
go ![elem]
acc = do
    Maybe elem
res <- ParserT l s e m (Maybe elem)
opt
    case Maybe elem
res of
      Maybe elem
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall chunk token. Chunked chunk token => [token] -> chunk
revTokensToChunk [elem]
acc)
      Just elem
a -> [elem] -> ParserT l s e m seq
go (forall chunk token. Chunked chunk token => token -> chunk -> chunk
consChunk elem
a [elem]
acc)

-- | Same as 'greedyStarParser' but discards the result.
greedyStarParser_ :: Monad m => ParserT l s e m a -> ParserT l s e m ()
greedyStarParser_ :: forall (m :: * -> *) l s e a.
Monad m =>
ParserT l s e m a -> ParserT l s e m ()
greedyStarParser_ ParserT l s e m a
parser = ParserT l s e m ()
go where
  opt :: ParserT l s e m (Maybe a)
opt = forall (m :: * -> *) l s e a.
Monad m =>
ParserT l s e m a -> ParserT l s e m (Maybe a)
optionalParser ParserT l s e m a
parser
  go :: ParserT l s e m ()
go = do
    Maybe a
res <- ParserT l s e m (Maybe a)
opt
    case Maybe a
res of
      Maybe a
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Just a
_ -> ParserT l s e m ()
go

-- | Yields the LONGEST string of 1 or more successes of the given parser.
-- Failures in the tail will be silenced, but those in the head will be returned.
greedyPlusParser :: (Chunked seq elem, Monad m) => ParserT l s e m elem -> ParserT l s e m seq
greedyPlusParser :: forall seq elem (m :: * -> *) l s e.
(Chunked seq elem, Monad m) =>
ParserT l s e m elem -> ParserT l s e m seq
greedyPlusParser ParserT l s e m elem
parser = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall chunk token. Chunked chunk token => token -> chunk -> chunk
consChunk ParserT l s e m elem
parser (forall seq elem (m :: * -> *) l s e.
(Chunked seq elem, Monad m) =>
ParserT l s e m elem -> ParserT l s e m seq
greedyStarParser ParserT l s e m elem
parser)

-- | Same as 'greedyPlusParser' but discards the result.
greedyPlusParser_ :: Monad m => ParserT l s e m a -> ParserT l s e m ()
greedyPlusParser_ :: forall (m :: * -> *) l s e a.
Monad m =>
ParserT l s e m a -> ParserT l s e m ()
greedyPlusParser_ ParserT l s e m a
parser = ParserT l s e m a
parser forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) l s e a.
Monad m =>
ParserT l s e m a -> ParserT l s e m ()
greedyStarParser_ ParserT l s e m a
parser

instance Monad m => Alternative (ParserT l s e m) where
  empty :: forall a. ParserT l s e m a
empty = forall (m :: * -> *) l s e a. Monad m => ParserT l s e m a
emptyParser
  <|> :: forall a.
ParserT l s e m a -> ParserT l s e m a -> ParserT l s e m a
(<|>) = forall (m :: * -> *) l s e a.
Monad m =>
ParserT l s e m a -> ParserT l s e m a -> ParserT l s e m a
orParser
  some :: forall a. ParserT l s e m a -> ParserT l s e m [a]
some = forall seq elem (m :: * -> *) l s e.
(Chunked seq elem, Monad m) =>
ParserT l s e m elem -> ParserT l s e m seq
greedyPlusParser
  many :: forall a. ParserT l s e m a -> ParserT l s e m [a]
many = forall seq elem (m :: * -> *) l s e.
(Chunked seq elem, Monad m) =>
ParserT l s e m elem -> ParserT l s e m seq
greedyStarParser

instance Monad m => MonadPlus (ParserT l s e m) where
  mzero :: forall a. ParserT l s e m a
mzero = forall (f :: * -> *) a. Alternative f => f a
empty
  mplus :: forall a.
ParserT l s e m a -> ParserT l s e m a -> ParserT l s e m a
mplus = forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

instance Monad m => MonadState s (ParserT l s e m) where
  get :: ParserT l s e m s
get = forall l s e (m :: * -> *) a.
(s -> m (Maybe (ParseResult l s e a))) -> ParserT l s e m a
ParserT (\s
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (forall l s e a. ParseSuccess s a -> ParseResult l s e a
ParseResultSuccess (forall s a. s -> a -> ParseSuccess s a
ParseSuccess s
s s
s))))
  put :: s -> ParserT l s e m ()
put s
t = forall l s e (m :: * -> *) a.
(s -> m (Maybe (ParseResult l s e a))) -> ParserT l s e m a
ParserT (\s
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (forall l s e a. ParseSuccess s a -> ParseResult l s e a
ParseResultSuccess (forall s a. s -> a -> ParseSuccess s a
ParseSuccess s
t ()))))
  state :: forall a. (s -> (a, s)) -> ParserT l s e m a
state s -> (a, s)
f = forall l s e (m :: * -> *) a.
(s -> m (Maybe (ParseResult l s e a))) -> ParserT l s e m a
ParserT (\s
s -> let (!a
a, !s
t) = s -> (a, s)
f s
s in forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (forall l s e a. ParseSuccess s a -> ParseResult l s e a
ParseResultSuccess (forall s a. s -> a -> ParseSuccess s a
ParseSuccess s
t a
a))))

-- | Catch only a subset of custom errors. This preserves label information vs rethrowing.
catchJustParser :: Monad m => (e -> Maybe b) -> ParserT l s e m a -> (b -> ParserT l s e m a) -> ParserT l s e m a
catchJustParser :: forall (m :: * -> *) e b l s a.
Monad m =>
(e -> Maybe b)
-> ParserT l s e m a
-> (b -> ParserT l s e m a)
-> ParserT l s e m a
catchJustParser e -> Maybe b
filterer ParserT l s e m a
parser b -> ParserT l s e m a
handler = forall l s e (m :: * -> *) a.
(s -> m (Maybe (ParseResult l s e a))) -> ParserT l s e m a
ParserT (\s
s0 -> forall l s e (m :: * -> *) a.
ParserT l s e m a -> s -> m (Maybe (ParseResult l s e a))
runParserT ParserT l s e m a
parser s
s0 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> Maybe (ParseResult l s e a) -> m (Maybe (ParseResult l s e a))
go s
s0) where
    go :: s -> Maybe (ParseResult l s e a) -> m (Maybe (ParseResult l s e a))
go s
s0 Maybe (ParseResult l s e a)
mres =
      case Maybe (ParseResult l s e a)
mres of
        Maybe (ParseResult l s e a)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Just ParseResult l s e a
res ->
          case ParseResult l s e a
res of
            ParseResultSuccess ParseSuccess s a
_ ->
              -- Nothing to catch, yield existing success
              forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ParseResult l s e a)
mres
            ParseResultError (ParseErrorBundle NESeq (ParseError l s e)
es) ->
              -- Find first custom error to handle
              s
-> Seq (ParseError l s e)
-> Seq (ParseError l s e)
-> m (Maybe (ParseResult l s e a))
goSplit s
s0 forall a. Seq a
Empty (forall a. NESeq a -> Seq a
NESeq.toSeq NESeq (ParseError l s e)
es)

    goSplit :: s
-> Seq (ParseError l s e)
-> Seq (ParseError l s e)
-> m (Maybe (ParseResult l s e a))
goSplit s
s0 Seq (ParseError l s e)
beforeEs Seq (ParseError l s e)
afterEs =
      case forall a b. (a -> Maybe b) -> Seq a -> Maybe (SeqPartition a b)
seqPartition forall l s e. ParseError l s e -> Maybe (s, e)
extractCustomError Seq (ParseError l s e)
afterEs of
        Maybe (SeqPartition (ParseError l s e) (s, e))
Nothing ->
          -- No next custom error, finally yield all other errors
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (f :: * -> *) a. Alternative f => f a
empty (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l s e a. ParseErrorBundle l s e -> ParseResult l s e a
ParseResultError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l s e. NESeq (ParseError l s e) -> ParseErrorBundle l s e
ParseErrorBundle) (forall a. Seq a -> Maybe (NESeq a)
NESeq.nonEmptySeq (Seq (ParseError l s e)
beforeEs forall a. Semigroup a => a -> a -> a
<> Seq (ParseError l s e)
afterEs)))
        Just SeqPartition (ParseError l s e) (s, e)
sep ->
          -- Found custom error - handle it
          s
-> Seq (ParseError l s e)
-> SeqPartition (ParseError l s e) (s, e)
-> m (Maybe (ParseResult l s e a))
goHandle s
s0 Seq (ParseError l s e)
beforeEs SeqPartition (ParseError l s e) (s, e)
sep

    goHandle :: s
-> Seq (ParseError l s e)
-> SeqPartition (ParseError l s e) (s, e)
-> m (Maybe (ParseResult l s e a))
goHandle s
s0 Seq (ParseError l s e)
beforeEs (SeqPartition Seq (ParseError l s e)
nextBeforeEs ParseError l s e
targetE (s
_, e
e) Seq (ParseError l s e)
afterEs) =
      case e -> Maybe b
filterer e
e of
        Maybe b
Nothing ->
          -- Not handling error;  - find next custom error
          s
-> Seq (ParseError l s e)
-> Seq (ParseError l s e)
-> m (Maybe (ParseResult l s e a))
goSplit s
s0 (Seq (ParseError l s e)
beforeEs forall a. Semigroup a => a -> a -> a
<> (ParseError l s e
targetE forall a. a -> Seq a -> Seq a
:<| Seq (ParseError l s e)
nextBeforeEs)) Seq (ParseError l s e)
afterEs
        Just b
b -> do
          -- NOTE(ejconlon) We resume parsing at the start state s0 (captured at catchError invocation)
          -- Is it reasonable to support parsing at the error state? (This is in the SeqPartition wildcard above)
          Maybe (ParseResult l s e a)
mres <- forall l s e (m :: * -> *) a.
ParserT l s e m a -> s -> m (Maybe (ParseResult l s e a))
runParserT (b -> ParserT l s e m a
handler b
b) s
s0
          case Maybe (ParseResult l s e a)
mres of
            Maybe (ParseResult l s e a)
Nothing ->
              -- No results from handled error - find next custom error
              s
-> Seq (ParseError l s e)
-> Seq (ParseError l s e)
-> m (Maybe (ParseResult l s e a))
goSplit s
s0 (Seq (ParseError l s e)
beforeEs forall a. Semigroup a => a -> a -> a
<> Seq (ParseError l s e)
nextBeforeEs) Seq (ParseError l s e)
afterEs
            Just ParseResult l s e a
res ->
              case ParseResult l s e a
res of
                ParseResultSuccess ParseSuccess s a
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ParseResult l s e a)
mres
                ParseResultError (ParseErrorBundle NESeq (ParseError l s e)
es) ->
                  -- Add to list of errors and find next custom error
                  s
-> Seq (ParseError l s e)
-> Seq (ParseError l s e)
-> m (Maybe (ParseResult l s e a))
goSplit s
s0 (Seq (ParseError l s e)
beforeEs forall a. Semigroup a => a -> a -> a
<> Seq (ParseError l s e)
nextBeforeEs forall a. Semigroup a => a -> a -> a
<> forall a. NESeq a -> Seq a
NESeq.toSeq NESeq (ParseError l s e)
es) Seq (ParseError l s e)
afterEs

-- | Throws a custom error
throwParser :: Monad m => e -> ParserT l s e m a
throwParser :: forall (m :: * -> *) e l s a. Monad m => e -> ParserT l s e m a
throwParser e
e = forall l s e (m :: * -> *) a.
(s -> m (Maybe (ParseResult l s e a))) -> ParserT l s e m a
ParserT (\s
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (forall l s e a. ParseErrorBundle l s e -> ParseResult l s e a
ParseResultError (forall l s e. NESeq (ParseError l s e) -> ParseErrorBundle l s e
ParseErrorBundle (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall l s e.
MarkStack l s -> s -> CompoundError s e -> ParseError l s e
ParseError forall a. Stack a
emptyStack s
s (forall s e. e -> CompoundError s e
CompoundErrorCustom e
e)))))))

-- | Catches a custom error
catchParser :: Monad m => ParserT l s e m a -> (e -> ParserT l s e m a) -> ParserT l s e m a
catchParser :: forall (m :: * -> *) l s e a.
Monad m =>
ParserT l s e m a -> (e -> ParserT l s e m a) -> ParserT l s e m a
catchParser = forall (m :: * -> *) e b l s a.
Monad m =>
(e -> Maybe b)
-> ParserT l s e m a
-> (b -> ParserT l s e m a)
-> ParserT l s e m a
catchJustParser forall a. a -> Maybe a
Just

instance Monad m => MonadError e (ParserT l s e m) where
  throwError :: forall a. e -> ParserT l s e m a
throwError = forall (m :: * -> *) e l s a. Monad m => e -> ParserT l s e m a
throwParser
  catchError :: forall a.
ParserT l s e m a -> (e -> ParserT l s e m a) -> ParserT l s e m a
catchError = forall (m :: * -> *) e b l s a.
Monad m =>
(e -> Maybe b)
-> ParserT l s e m a
-> (b -> ParserT l s e m a)
-> ParserT l s e m a
catchJustParser forall a. a -> Maybe a
Just

-- | A simple failing parser
failParser :: Monad m => Text -> ParserT l s e m a
failParser :: forall (m :: * -> *) l s e a. Monad m => Text -> ParserT l s e m a
failParser Text
msg = forall l s e (m :: * -> *) a.
(s -> m (Maybe (ParseResult l s e a))) -> ParserT l s e m a
ParserT (\s
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (forall l s e a. ParseErrorBundle l s e -> ParseResult l s e a
ParseResultError (forall l s e. NESeq (ParseError l s e) -> ParseErrorBundle l s e
ParseErrorBundle (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall l s e.
MarkStack l s -> s -> CompoundError s e -> ParseError l s e
ParseError forall a. Stack a
emptyStack s
s (forall s e. Text -> CompoundError s e
CompoundErrorFail Text
msg)))))))

instance Monad m => MonadFail (ParserT l s e m) where
  fail :: forall a. String -> ParserT l s e m a
fail = forall (m :: * -> *) l s e a. Monad m => Text -> ParserT l s e m a
failParser forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

liftParser :: Monad m => m a -> ParserT l s e m a
liftParser :: forall (m :: * -> *) a l s e. Monad m => m a -> ParserT l s e m a
liftParser m a
ma = forall l s e (m :: * -> *) a.
(s -> m (Maybe (ParseResult l s e a))) -> ParserT l s e m a
ParserT (\s
s -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l s e a. ParseSuccess s a -> ParseResult l s e a
ParseResultSuccess forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. s -> a -> ParseSuccess s a
ParseSuccess s
s) m a
ma)

instance MonadTrans (ParserT l s e) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> ParserT l s e m a
lift = forall (m :: * -> *) a l s e. Monad m => m a -> ParserT l s e m a
liftParser

hoistParser :: (forall x. m x -> n x) -> ParserT l s e m a -> ParserT l s e n a
hoistParser :: forall (m :: * -> *) (n :: * -> *) l s e a.
(forall x. m x -> n x) -> ParserT l s e m a -> ParserT l s e n a
hoistParser forall x. m x -> n x
trans (ParserT s -> m (Maybe (ParseResult l s e a))
f) = forall l s e (m :: * -> *) a.
(s -> m (Maybe (ParseResult l s e a))) -> ParserT l s e m a
ParserT (forall x. m x -> n x
trans forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m (Maybe (ParseResult l s e a))
f)

instance MFunctor (ParserT l s e) where
  hoist :: forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> ParserT l s e m b -> ParserT l s e n b
hoist = forall (m :: * -> *) (n :: * -> *) l s e a.
(forall x. m x -> n x) -> ParserT l s e m a -> ParserT l s e n a
hoistParser

-- | If the parser does not succeed, yield the given value.
defaultParser :: Monad m => a -> ParserT l s e m a -> ParserT l s e m a
defaultParser :: forall (m :: * -> *) a l s e.
Monad m =>
a -> ParserT l s e m a -> ParserT l s e m a
defaultParser a
val ParserT l s e m a
parser = forall (m :: * -> *) l s e a.
Monad m =>
ParserT l s e m a -> ParserT l s e m a -> ParserT l s e m a
orParser ParserT l s e m a
parser (forall (f :: * -> *) a. Applicative f => a -> f a
pure a
val)

-- | A parser that yields 'Nothing' if the parser does not succeed, otherwise
-- wraps success in 'Just'.
optionalParser :: Monad m => ParserT l s e m a -> ParserT l s e m (Maybe a)
optionalParser :: forall (m :: * -> *) l s e a.
Monad m =>
ParserT l s e m a -> ParserT l s e m (Maybe a)
optionalParser ParserT l s e m a
parser = forall (m :: * -> *) a l s e.
Monad m =>
a -> ParserT l s e m a -> ParserT l s e m a
defaultParser forall a. Maybe a
Nothing (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just ParserT l s e m a
parser)

-- | Run the parser speculatively and return results. Does not advance state or throw errors.
reflectParser :: Monad m => ParserT l s e m a -> ParserT l s e m (Maybe (ParseResult l s e a))
reflectParser :: forall (m :: * -> *) l s e a.
Monad m =>
ParserT l s e m a -> ParserT l s e m (Maybe (ParseResult l s e a))
reflectParser ParserT l s e m a
parser = forall l s e (m :: * -> *) a.
(s -> m (Maybe (ParseResult l s e a))) -> ParserT l s e m a
ParserT s -> m (Maybe (ParseResult l s e (Maybe (ParseResult l s e a))))
go where
  go :: s -> m (Maybe (ParseResult l s e (Maybe (ParseResult l s e a))))
go s
s = do
    Maybe (ParseResult l s e a)
mres <- forall l s e (m :: * -> *) a.
ParserT l s e m a -> s -> m (Maybe (ParseResult l s e a))
runParserT ParserT l s e m a
parser s
s
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (forall l s e a. ParseSuccess s a -> ParseResult l s e a
ParseResultSuccess (forall s a. s -> a -> ParseSuccess s a
ParseSuccess s
s Maybe (ParseResult l s e a)
mres)))

-- | Removes all failures from the parse results. Catches more errors than 'catchError (const empty)'
-- because this includes stream errors, not just custom errors.
-- If you want more fine-grained control, use 'reflectParser' and map over the results.
silenceParser :: Monad m => ParserT l s e m a -> ParserT l s e m a
silenceParser :: forall (m :: * -> *) l s e a.
Monad m =>
ParserT l s e m a -> ParserT l s e m a
silenceParser ParserT l s e m a
parser = forall l s e (m :: * -> *) a.
(s -> m (Maybe (ParseResult l s e a))) -> ParserT l s e m a
ParserT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {l} {s} {e} {a}.
Maybe (ParseResult l s e a) -> Maybe (ParseResult l s e a)
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l s e (m :: * -> *) a.
ParserT l s e m a -> s -> m (Maybe (ParseResult l s e a))
runParserT ParserT l s e m a
parser) where
  go :: Maybe (ParseResult l s e a) -> Maybe (ParseResult l s e a)
go Maybe (ParseResult l s e a)
mres =
    case Maybe (ParseResult l s e a)
mres of
      Just (ParseResultSuccess ParseSuccess s a
_) -> Maybe (ParseResult l s e a)
mres
      Maybe (ParseResult l s e a)
_ -> forall a. Maybe a
Nothing

-- | Yield the results of the given parser, but rewind back to the starting state.
-- Note that these results may contain errors, so you may want to stifle them with 'silenceParser', for example.
lookAheadParser :: Monad m => ParserT l s e m a -> ParserT l s e m a
lookAheadParser :: forall (m :: * -> *) l s e a.
Monad m =>
ParserT l s e m a -> ParserT l s e m a
lookAheadParser ParserT l s e m a
parser = forall l s e (m :: * -> *) a.
(s -> m (Maybe (ParseResult l s e a))) -> ParserT l s e m a
ParserT (\s
s -> 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 (forall {s} {l} {e} {a}.
s -> ParseResult l s e a -> ParseResult l s e a
go s
s)) (forall l s e (m :: * -> *) a.
ParserT l s e m a -> s -> m (Maybe (ParseResult l s e a))
runParserT ParserT l s e m a
parser s
s)) where
  go :: s -> ParseResult l s e a -> ParseResult l s e a
go s
s ParseResult l s e a
res =
    case ParseResult l s e a
res of
      ParseResultError ParseErrorBundle l s e
es -> forall l s e a. ParseErrorBundle l s e -> ParseResult l s e a
ParseResultError ParseErrorBundle l s e
es
      ParseResultSuccess (ParseSuccess s
_ a
a) -> forall l s e a. ParseSuccess s a -> ParseResult l s e a
ParseResultSuccess (forall s a. s -> a -> ParseSuccess s a
ParseSuccess s
s a
a)

-- | Push the label and current state onto the parse error mark stack.
-- Useful to delimit named sub-spans for error reporting.
markParser :: Monad m => Maybe l -> ParserT l s e m a -> ParserT l s e m a
markParser :: forall (m :: * -> *) l s e a.
Monad m =>
Maybe l -> ParserT l s e m a -> ParserT l s e m a
markParser Maybe l
ml ParserT l s e m a
parser = forall l s e (m :: * -> *) a.
(s -> m (Maybe (ParseResult l s e a))) -> ParserT l s e m a
ParserT (\s
s -> 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 (s -> ParseResult l s e a -> ParseResult l s e a
go s
s)) (forall l s e (m :: * -> *) a.
ParserT l s e m a -> s -> m (Maybe (ParseResult l s e a))
runParserT ParserT l s e m a
parser s
s)) where
  go :: s -> ParseResult l s e a -> ParseResult l s e a
go s
s ParseResult l s e a
res =
    case ParseResult l s e a
res of
      ParseResultError (ParseErrorBundle NESeq (ParseError l s e)
es) -> forall l s e a. ParseErrorBundle l s e -> ParseResult l s e a
ParseResultError (forall l s e. NESeq (ParseError l s e) -> ParseErrorBundle l s e
ParseErrorBundle (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l s e. Mark l s -> ParseError l s e -> ParseError l s e
markParseError (forall l s. Maybe l -> s -> Mark l s
Mark Maybe l
ml s
s)) NESeq (ParseError l s e)
es))
      ParseResultSuccess ParseSuccess s a
_ -> ParseResult l s e a
res

-- | Like 'markParser' but allows you to mutate state. See 'withToken' and 'withChunk'.
markWithStateParser :: Monad m => Maybe l -> (s -> (b, s)) -> (b -> ParserT l s e m a) -> ParserT l s e m a
markWithStateParser :: forall (m :: * -> *) l s b e a.
Monad m =>
Maybe l
-> (s -> (b, s)) -> (b -> ParserT l s e m a) -> ParserT l s e m a
markWithStateParser Maybe l
ml s -> (b, s)
g b -> ParserT l s e m a
f = forall (m :: * -> *) l s e a.
Monad m =>
Maybe l -> ParserT l s e m a -> ParserT l s e m a
markParser Maybe l
ml (forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state s -> (b, s)
g forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> ParserT l s e m a
f)

-- | Like 'markParser' but allows you to mutate state. See 'withToken' and 'withChunk'.
markWithOptStateParser :: Monad m => Maybe l -> (s -> Maybe (b, s)) -> (Maybe b -> ParserT l s e m a) -> ParserT l s e m a
markWithOptStateParser :: forall (m :: * -> *) l s b e a.
Monad m =>
Maybe l
-> (s -> Maybe (b, s))
-> (Maybe b -> ParserT l s e m a)
-> ParserT l s e m a
markWithOptStateParser Maybe l
ml s -> Maybe (b, s)
g = forall (m :: * -> *) l s b e a.
Monad m =>
Maybe l
-> (s -> (b, s)) -> (b -> ParserT l s e m a) -> ParserT l s e m a
markWithStateParser Maybe l
ml (\s
s -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Maybe a
Nothing, s
s) (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. a -> Maybe a
Just) (s -> Maybe (b, s)
g s
s))

-- | Clear marks from parse errors. You can mark immediately after to widen the narrowest
-- marked span to the range you want to report.
unmarkParser :: Monad m => ParserT l s e m a -> ParserT l s e m a
unmarkParser :: forall (m :: * -> *) l s e a.
Monad m =>
ParserT l s e m a -> ParserT l s e m a
unmarkParser ParserT l s e m a
parser = forall l s e (m :: * -> *) a.
(s -> m (Maybe (ParseResult l s e a))) -> ParserT l s e m a
ParserT (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 forall {l} {s} {e} {a}. ParseResult l s e a -> ParseResult l s e a
go) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l s e (m :: * -> *) a.
ParserT l s e m a -> s -> m (Maybe (ParseResult l s e a))
runParserT ParserT l s e m a
parser) where
  go :: ParseResult l s e a -> ParseResult l s e a
go ParseResult l s e a
res =
    case ParseResult l s e a
res of
      ParseResultError (ParseErrorBundle NESeq (ParseError l s e)
es) -> forall l s e a. ParseErrorBundle l s e -> ParseResult l s e a
ParseResultError (forall l s e. NESeq (ParseError l s e) -> ParseErrorBundle l s e
ParseErrorBundle (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall l s e. ParseError l s e -> ParseError l s e
unmarkParseError NESeq (ParseError l s e)
es))
      ParseResultSuccess ParseSuccess s a
_ -> ParseResult l s e a
res

-- | If the first parser succeeds in the initial state, yield results from the second parser in the initial
-- state. This is likely the look-ahead you want, since errors from the first parser are completely ignored.
-- Use the first parser to check a prefix of input, and use the second to consume that input.
commitParser :: Monad m => ParserT l s e m () -> ParserT l s e m a -> ParserT l s e m a
commitParser :: forall (m :: * -> *) l s e a.
Monad m =>
ParserT l s e m () -> ParserT l s e m a -> ParserT l s e m a
commitParser ParserT l s e m ()
checker ParserT l s e m a
parser = do
  s
s <- forall s (m :: * -> *). MonadState s m => m s
get
  Maybe ()
o <- forall (m :: * -> *) l s e a.
Monad m =>
ParserT l s e m a -> ParserT l s e m (Maybe a)
optionalParser ParserT l s e m ()
checker
  case Maybe ()
o of
    Maybe ()
Nothing -> forall (f :: * -> *) a. Alternative f => f a
empty
    Just ()
_ -> forall s (m :: * -> *). MonadState s m => s -> m ()
put s
s forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParserT l s e m a
parser

-- | If the first parser yields NO results (success or failure), yield from the second.
-- Note that this is different from 'orParser' in that it does not try the second if there
-- are errors in the first. You might use this on the outside of a complex parser with
-- a fallback to 'fail' to indicate that there are no matches.
onEmptyParser :: Parser l s e a -> Parser l s e a -> Parser l s e a
onEmptyParser :: forall l s e a. Parser l s e a -> Parser l s e a -> Parser l s e a
onEmptyParser Parser l s e a
parser Parser l s e a
fallback = forall l s e (m :: * -> *) a.
(s -> m (Maybe (ParseResult l s e a))) -> ParserT l s e m a
ParserT (\s
s -> forall l s e (m :: * -> *) a.
ParserT l s e m a -> s -> m (Maybe (ParseResult l s e a))
runParserT Parser l s e a
parser s
s forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s
-> Maybe (ParseResult l s e a)
-> Identity (Maybe (ParseResult l s e a))
go s
s) where
  go :: s
-> Maybe (ParseResult l s e a)
-> Identity (Maybe (ParseResult l s e a))
go s
s Maybe (ParseResult l s e a)
mres =
    case Maybe (ParseResult l s e a)
mres of
      Maybe (ParseResult l s e a)
Nothing -> forall l s e (m :: * -> *) a.
ParserT l s e m a -> s -> m (Maybe (ParseResult l s e a))
runParserT Parser l s e a
fallback s
s
      Just ParseResult l s e a
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ParseResult l s e a)
mres

-- Private utility functions

data SeqPartition a b = SeqPartition
  { forall a b. SeqPartition a b -> Seq a
spBefore :: !(Seq a)
  , forall a b. SeqPartition a b -> a
spKey :: !a
  , forall a b. SeqPartition a b -> b
spValue :: !b
  , forall a b. SeqPartition a b -> Seq a
spAfter :: !(Seq a)
  } deriving (SeqPartition a b -> SeqPartition a b -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b.
(Eq a, Eq b) =>
SeqPartition a b -> SeqPartition a b -> Bool
/= :: SeqPartition a b -> SeqPartition a b -> Bool
$c/= :: forall a b.
(Eq a, Eq b) =>
SeqPartition a b -> SeqPartition a b -> Bool
== :: SeqPartition a b -> SeqPartition a b -> Bool
$c== :: forall a b.
(Eq a, Eq b) =>
SeqPartition a b -> SeqPartition a b -> Bool
Eq, Int -> SeqPartition a b -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> SeqPartition a b -> ShowS
forall a b. (Show a, Show b) => [SeqPartition a b] -> ShowS
forall a b. (Show a, Show b) => SeqPartition a b -> String
showList :: [SeqPartition a b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [SeqPartition a b] -> ShowS
show :: SeqPartition a b -> String
$cshow :: forall a b. (Show a, Show b) => SeqPartition a b -> String
showsPrec :: Int -> SeqPartition a b -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> SeqPartition a b -> ShowS
Show)

seqPartition :: (a -> Maybe b) -> Seq a -> Maybe (SeqPartition a b)
seqPartition :: forall a b. (a -> Maybe b) -> Seq a -> Maybe (SeqPartition a b)
seqPartition a -> Maybe b
f = Seq a -> Seq a -> Maybe (SeqPartition a b)
go forall a. Seq a
Empty where
  go :: Seq a -> Seq a -> Maybe (SeqPartition a b)
go Seq a
before Seq a
after =
    case Seq a
after of
      Seq a
Empty -> forall a. Maybe a
Nothing
      (a
x :<| Seq a
xs) ->
        case a -> Maybe b
f a
x of
          Maybe b
Nothing -> Seq a -> Seq a -> Maybe (SeqPartition a b)
go (Seq a
before forall a. Seq a -> a -> Seq a
:|> a
x) Seq a
xs
          Just b
y -> forall a. a -> Maybe a
Just (forall a b. Seq a -> a -> b -> Seq a -> SeqPartition a b
SeqPartition Seq a
before a
x b
y Seq a
xs)

extractCustomError :: ParseError l s e -> Maybe (s, e)
extractCustomError :: forall l s e. ParseError l s e -> Maybe (s, e)
extractCustomError pe :: ParseError l s e
pe@(ParseError MarkStack l s
_ s
_ CompoundError s e
ce) =
  case CompoundError s e
ce of
    CompoundErrorCustom e
e -> forall a. a -> Maybe a
Just (forall l s e. ParseError l s e -> s
parseErrorResume ParseError l s e
pe, e
e)
    CompoundError s e
_ -> forall a. Maybe a
Nothing