{-|
Module      : Data.Profunctor.Grammar.Parsector
Description : grammar distributor with failures
Copyright   : (C) 2026 - Eitan Chatav
License     : BSD-style (see the file LICENSE)
Maintainer  : Eitan Chatav <eitan.chatav@gmail.com>
Stability   : provisional
Portability : non-portable

See Leijen,
[Parsec: Direct Style Monadic Parser Combinators For The Real World]
(https://www.microsoft.com/en-us/research/wp-content/uploads/2016/02/parsec-paper-letter.pdf)
-}

module Data.Profunctor.Grammar.Parsector
  ( -- * Parsector
    Parsector (..)
  , parsecP
  , unparsecP
  , ParsecState (..)
  , ParsecFailure (..)
  ) where

import Control.Applicative
import Control.Arrow
import Control.Category
import Data.Function (fix)
import Control.Lens
import Control.Lens.Grammar.BackusNaur
import Control.Lens.Grammar.Boole
import Control.Lens.Grammar.Kleene
import Control.Lens.Grammar.Symbol
import Control.Lens.Grammar.Token
import Control.Lens.PartialIso
import Control.Monad
import Control.Monad.Fail.Try
import Data.Profunctor
import Data.Profunctor.Distributor
import Data.Profunctor.Filtrator
import Data.Profunctor.Monoidal
import Data.Tree
import GHC.Exts
import Prelude hiding (id, (.))

{- | `Parsector` is an invertible @LL(1)@ parser which is intended
to provide detailed failure information, based on [Parsec]
(https://www.microsoft.com/en-us/research/wp-content/uploads/2016/02/parsec-paper-letter.pdf).
-}
newtype Parsector s a b = Parsector
  {forall s a b.
Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
runParsector :: forall x. (ParsecState s b -> x) -> ParsecState s a -> x}

{- | Run `Parsector` as a parser: consume tokens from @s@,
left to right, returning a `ParsecState` whose `parsecResult`
is `Nothing` on failure and `Just` the output syntax value on success. -}
parsecP
  :: Categorized (Item s)
  => Parsector s a b
  -> s -- ^ input stream
  -> ParsecState s b
parsecP :: forall s a b.
Categorized (Item s) =>
Parsector s a b -> s -> ParsecState s b
parsecP Parsector s a b
p s
s = Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
forall s a b.
Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
runParsector Parsector s a b
p ParsecState s b -> ParsecState s b
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id (Bool -> Word -> s -> ParsecFailure s -> Maybe a -> ParsecState s a
forall s a.
Bool -> Word -> s -> ParsecFailure s -> Maybe a -> ParsecState s a
ParsecState Bool
False Word
0 s
s ParsecFailure s
forall a. Monoid a => a
mempty Maybe a
forall a. Maybe a
Nothing)

{- | Run `Parsector` as a printer: given a syntax value @a@ and
an input stream, append tokens to @s@ left to right,
returning a `ParsecState` whose `parsecResult` is
`Nothing` on failure or `Just` a successful output syntax value,
in which case, `parsecStream` is the output stream. -}
unparsecP
  :: Categorized (Item s)
  => Parsector s a b
  -> a -- ^ input syntax
  -> s -- ^ input stream
  -> ParsecState s b
unparsecP :: forall s a b.
Categorized (Item s) =>
Parsector s a b -> a -> s -> ParsecState s b
unparsecP Parsector s a b
p a
a s
s = Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
forall s a b.
Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
runParsector Parsector s a b
p ParsecState s b -> ParsecState s b
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id (Bool -> Word -> s -> ParsecFailure s -> Maybe a -> ParsecState s a
forall s a.
Bool -> Word -> s -> ParsecFailure s -> Maybe a -> ParsecState s a
ParsecState Bool
False Word
0 s
s ParsecFailure s
forall a. Monoid a => a
mempty (a -> Maybe a
forall a. a -> Maybe a
Just a
a))

{- | `ParsecState` is both the input and output type of the
underlying function inside `Parsector`.
@Parsector s a b@ is equivalent to

@ParsecState s a -> ParsecState s b@

So `ParsecState` has a dual interpretation as input and output. -}
data ParsecState s a = ParsecState
  { forall s a. ParsecState s a -> Bool
parsecLooked :: !Bool
    {- ^ `True` once the parser has consumed/produced at least one token
    since the last `<|>` / `try` decision point.
    Controls @LL(1)@ commitment: a failure with `parsecLooked` `True`
    is propagated immediately without trying alternatives.
    Reset to `False` by `try` on failure.
    -}
  , forall s a. ParsecState s a -> Word
parsecOffset :: !Word
    -- ^ Number of tokens consumed from the start of the stream.
  , forall s a. ParsecState s a -> s
parsecStream :: s -- ^ stream
  , forall s a. ParsecState s a -> ParsecFailure s
parsecFailure  :: ParsecFailure s
    {- ^ `ParsecFailure` channel.

    * If `parsecResult` is `Nothing`, this is the hard failure.
    * If `parsecResult` is `Just`, this is deferred failure/hint info
      from empty-failing alternatives at the current position.

    `<|>` and `>>=` propagate and merge this field to preserve
    expected-token reporting on downstream failures.
    -}
  , forall s a. ParsecState s a -> Maybe a
parsecResult :: Maybe a
    {- ^
    As input, `Nothing` means parse mode and
    `Just` means print mode with an input syntax value.

    As output `Nothing` means failure (inspect `parsecFailure`) and
    `Just` means success with an output syntax value.
    -}
  }

{- | `ParsecFailure` is the failure payload produced by `Parsector`,
stored in `parsecFailure`.
`ParsecFailure` is a `Monoid` and `Parsector` merges failures/hints
when control flow reaches the same offset without commitment.
-}
data ParsecFailure s = ParsecFailure
  { forall s. ParsecFailure s -> TokenClass (Item s)
parsecExpect :: TokenClass (Item s)
    {- ^ Class of expected token `Item`s at the `parsecOffset`.
    `tokenClass`es and `Tokenized` combinators specify expectations.
    Under `<>`, expectations are combined with disjunction `>||<`.
    In case of a parse failure, contrast with the actual `parsecStream`,
    which is either unexpectedly empty or begins with an unexpected token.
    -}
  , forall s. ParsecFailure s -> [Tree String]
parsecLabels :: [Tree String]
    {- ^ Forest of `rule` labels active at the `parsecOffset`.
    Each `rule` wraps its inner labels in a new `Node`.
    `ruleRec` & `fail` also create label nodes.
    Under `<>`, forests are concatenated as siblings.
    Use `drawForest` to display.
    -}
  }

-- ParsecFailure instances
deriving stock instance
  ( Categorized (Item s)
  , Show (Item s), Show (Categorize (Item s))
  ) => Show (ParsecFailure s)
deriving stock instance
  ( Categorized (Item s)
  , Read (Item s), Read (Categorize (Item s))
  ) => Read (ParsecFailure s)
deriving stock instance Categorized (Item s) => Eq (ParsecFailure s)
deriving stock instance Categorized (Item s) => Ord (ParsecFailure s)
instance Categorized (Item s) => Semigroup (ParsecFailure s) where
  ParsecFailure TokenClass (Item s)
e1 [Tree String]
l1 <> :: ParsecFailure s -> ParsecFailure s -> ParsecFailure s
<> ParsecFailure TokenClass (Item s)
e2 [Tree String]
l2 = TokenClass (Item s) -> [Tree String] -> ParsecFailure s
forall s. TokenClass (Item s) -> [Tree String] -> ParsecFailure s
ParsecFailure (TokenClass (Item s)
e1 TokenClass (Item s) -> TokenClass (Item s) -> TokenClass (Item s)
forall b. BooleanAlgebra b => b -> b -> b
>||< TokenClass (Item s)
e2) ([Tree String]
l1 [Tree String] -> [Tree String] -> [Tree String]
forall a. [a] -> [a] -> [a]
++ [Tree String]
l2)
instance Categorized (Item s) => Monoid (ParsecFailure s) where
  mempty :: ParsecFailure s
mempty = TokenClass (Item s) -> [Tree String] -> ParsecFailure s
forall s. TokenClass (Item s) -> [Tree String] -> ParsecFailure s
ParsecFailure TokenClass (Item s)
forall b. BooleanAlgebra b => b
falseB []

-- ParsecState instances
deriving stock instance Functor (ParsecState s)
deriving stock instance Foldable (ParsecState s)
deriving stock instance Traversable (ParsecState s)
deriving stock instance
  ( Categorized (Item s)
  , Show (Item s), Show (Categorize (Item s))
  , Show a, Show s
  ) => Show (ParsecState s a)
deriving stock instance
  ( Categorized (Item s)
  , Read (Item s), Read (Categorize (Item s))
  , Read a, Read s
  ) => Read (ParsecState s a)
deriving stock instance
  ( Categorized (Item s)
  , Eq a, Eq s
  ) => Eq (ParsecState s a)
deriving stock instance
  ( Categorized (Item s)
  , Ord a, Ord s
  ) => Ord (ParsecState s a)

-- Parsector instances
instance
  ( Categorized token, Item s ~ token
  , Cons s s token token, Snoc s s token token
  ) => Tokenized token (Parsector s token token) where
  anyToken :: Parsector s token token
anyToken = TokenClass token -> Parsector s token token
forall token p. TokenAlgebra token p => TokenClass token -> p
tokenClass TokenClass token
forall token p. Tokenized token p => p
anyToken
  token :: token -> Parsector s token token
token token
t = TokenClass token -> Parsector s token token
forall token p. TokenAlgebra token p => TokenClass token -> p
tokenClass (token -> TokenClass token
forall token p. Tokenized token p => token -> p
token token
t)
  oneOf :: forall (f :: * -> *).
Foldable f =>
f token -> Parsector s token token
oneOf f token
ts = TokenClass token -> Parsector s token token
forall token p. TokenAlgebra token p => TokenClass token -> p
tokenClass (f token -> TokenClass token
forall token p (f :: * -> *).
(Tokenized token p, Foldable f) =>
f token -> p
forall (f :: * -> *). Foldable f => f token -> TokenClass token
oneOf f token
ts)
  notOneOf :: forall (f :: * -> *).
Foldable f =>
f token -> Parsector s token token
notOneOf f token
ts = TokenClass token -> Parsector s token token
forall token p. TokenAlgebra token p => TokenClass token -> p
tokenClass (f token -> TokenClass token
forall token p (f :: * -> *).
(Tokenized token p, Foldable f) =>
f token -> p
forall (f :: * -> *). Foldable f => f token -> TokenClass token
notOneOf f token
ts)
  asIn :: Categorize token -> Parsector s token token
asIn Categorize token
cat = TokenClass token -> Parsector s token token
forall token p. TokenAlgebra token p => TokenClass token -> p
tokenClass (Categorize token -> TokenClass token
forall token p. Tokenized token p => Categorize token -> p
asIn Categorize token
cat)
  notAsIn :: Categorize token -> Parsector s token token
notAsIn Categorize token
cat = TokenClass token -> Parsector s token token
forall token p. TokenAlgebra token p => TokenClass token -> p
tokenClass (Categorize token -> TokenClass token
forall token p. Tokenized token p => Categorize token -> p
notAsIn Categorize token
cat)
instance
  ( Categorized token, Item s ~ token
  , Cons s s token token, Snoc s s token token
  ) => TokenAlgebra token (Parsector s token token) where
    tokenClass :: TokenClass token -> Parsector s token token
tokenClass TokenClass token
test = (forall x. (ParsecState s token -> x) -> ParsecState s token -> x)
-> Parsector s token token
forall s a b.
(forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
Parsector ((forall x. (ParsecState s token -> x) -> ParsecState s token -> x)
 -> Parsector s token token)
-> (forall x.
    (ParsecState s token -> x) -> ParsecState s token -> x)
-> Parsector s token token
forall a b. (a -> b) -> a -> b
$ \ParsecState s token -> x
callback ParsecState s token
query ->
      let
        stream :: s
stream = ParsecState s token -> s
forall s a. ParsecState s a -> s
parsecStream ParsecState s token
query
        mode :: Maybe token
mode = ParsecState s token -> Maybe token
forall s a. ParsecState s a -> Maybe a
parsecResult ParsecState s token
query
        offset :: Word
offset = ParsecState s token -> Word
forall s a. ParsecState s a -> Word
parsecOffset ParsecState s token
query
        replyOk :: token -> s -> ParsecState s token
replyOk token
tok s
str = ParsecState s token
query
          { parsecLooked = True
          , parsecFailure  = mempty
          , parsecStream = str
          , parsecOffset = offset + 1
          , parsecResult = Just tok
          }
        replyErr :: ParsecState s token
replyErr = ParsecState s token
query
          { parsecFailure  = ParsecFailure test []
          , parsecResult = Nothing }
      in
        ParsecState s token -> x
callback (ParsecState s token -> x) -> ParsecState s token -> x
forall a b. (a -> b) -> a -> b
$ case Maybe token
mode of
          -- print mode
          Just token
tok
            | TokenClass token -> token -> Bool
forall token p. TokenAlgebra token p => TokenClass token -> p
tokenClass TokenClass token
test token
tok -> token -> s -> ParsecState s token
replyOk token
tok (s -> token -> s
forall s a. Snoc s s a a => s -> a -> s
snoc s
stream token
tok)
            | Bool
otherwise -> ParsecState s token
replyErr
          -- parse mode
          Maybe token
Nothing -> case s -> Maybe (token, s)
forall s a. Cons s s a a => s -> Maybe (a, s)
uncons s
stream of
            Just (token
tok, s
rest)
              | TokenClass token -> token -> Bool
forall token p. TokenAlgebra token p => TokenClass token -> p
tokenClass TokenClass token
test token
tok -> token -> s -> ParsecState s token
replyOk token
tok s
rest
              | Bool
otherwise -> ParsecState s token
replyErr
            Maybe (token, s)
Nothing -> ParsecState s token
replyErr
instance BackusNaurForm (Parsector s a b) where
  -- | Wraps inner `parsecLabels` in a new `Node name` on failure.
  -- Has no effect on success.
  rule :: String -> Parsector s a b -> Parsector s a b
rule String
name Parsector s a b
p = (forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
forall s a b.
(forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
Parsector ((forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
 -> Parsector s a b)
-> (forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
forall a b. (a -> b) -> a -> b
$ \ParsecState s b -> x
callback ParsecState s a
query ->
    ((ParsecState s b -> x) -> ParsecState s a -> x)
-> ParsecState s a -> (ParsecState s b -> x) -> x
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
forall s a b.
Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
runParsector Parsector s a b
p) ParsecState s a
query ((ParsecState s b -> x) -> x) -> (ParsecState s b -> x) -> x
forall a b. (a -> b) -> a -> b
$ \ParsecState s b
reply -> ParsecState s b -> x
callback (ParsecState s b -> x) -> ParsecState s b -> x
forall a b. (a -> b) -> a -> b
$
      case ParsecState s b -> Maybe b
forall s a. ParsecState s a -> Maybe a
parsecResult ParsecState s b
reply of
        Maybe b
Nothing -> ParsecState s b
reply
          { parsecFailure =
              let ParsecFailure expect labels = parsecFailure reply
              in ParsecFailure expect [Node name labels]
          }
        Just b
_ -> ParsecState s b
reply
  ruleRec :: String -> (Parsector s a b -> Parsector s a b) -> Parsector s a b
ruleRec String
name = String -> Parsector s a b -> Parsector s a b
forall bnf. BackusNaurForm bnf => String -> bnf -> bnf
rule String
name (Parsector s a b -> Parsector s a b)
-> ((Parsector s a b -> Parsector s a b) -> Parsector s a b)
-> (Parsector s a b -> Parsector s a b)
-> Parsector s a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Parsector s a b -> Parsector s a b) -> Parsector s a b
forall a. (a -> a) -> a
fix
instance
  ( Categorized token, Item s ~ token
  , Cons s s token token, Snoc s s token token
  ) => TerminalSymbol token (Parsector s () ())
instance Functor (Parsector s a) where
  fmap :: forall a b. (a -> b) -> Parsector s a a -> Parsector s a b
fmap = (a -> b) -> Parsector s a a -> Parsector s a b
forall b c a. (b -> c) -> Parsector s a b -> Parsector s a c
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap
instance Categorized (Item s) => Applicative (Parsector s a) where
  pure :: forall a. a -> Parsector s a a
pure a
b = (forall x. (ParsecState s a -> x) -> ParsecState s a -> x)
-> Parsector s a a
forall s a b.
(forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
Parsector ((forall x. (ParsecState s a -> x) -> ParsecState s a -> x)
 -> Parsector s a a)
-> (forall x. (ParsecState s a -> x) -> ParsecState s a -> x)
-> Parsector s a a
forall a b. (a -> b) -> a -> b
$ \ParsecState s a -> x
callback ParsecState s a
query ->
    ParsecState s a -> x
callback ParsecState s a
query { parsecResult = Just b }
  <*> :: forall a b.
Parsector s a (a -> b) -> Parsector s a a -> Parsector s a b
(<*>) = Parsector s a (a -> b) -> Parsector s a a -> Parsector s a b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Categorized (Item s) => Monad (Parsector s a) where
  return :: forall a. a -> Parsector s a a
return = a -> Parsector s a a
forall a. a -> Parsector s a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Parsector s a a
p >>= :: forall a b.
Parsector s a a -> (a -> Parsector s a b) -> Parsector s a b
>>= a -> Parsector s a b
f = (forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
forall s a b.
(forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
Parsector ((forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
 -> Parsector s a b)
-> (forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
forall a b. (a -> b) -> a -> b
$ \ParsecState s b -> x
callback ParsecState s a
query ->
    ((ParsecState s a -> x) -> ParsecState s a -> x)
-> ParsecState s a -> (ParsecState s a -> x) -> x
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Parsector s a a
-> forall x. (ParsecState s a -> x) -> ParsecState s a -> x
forall s a b.
Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
runParsector Parsector s a a
p) ParsecState s a
query ((ParsecState s a -> x) -> x) -> (ParsecState s a -> x) -> x
forall a b. (a -> b) -> a -> b
$ \ParsecState s a
reply ->
      case ParsecState s a -> Maybe a
forall s a. ParsecState s a -> Maybe a
parsecResult ParsecState s a
reply of
        Maybe a
Nothing -> ParsecState s b -> x
callback ParsecState s a
reply { parsecResult = Nothing }
        Just a
b ->
          let
            hintP :: ParsecFailure s
hintP  = ParsecState s a -> ParsecFailure s
forall s a. ParsecState s a -> ParsecFailure s
parsecFailure ParsecState s a
reply
            fQuery :: ParsecState s a
fQuery = ParsecState s a
reply
              { parsecLooked = False
              , parsecFailure  = mempty
              , parsecResult = parsecResult query
              }
          in
            ((ParsecState s b -> x) -> ParsecState s a -> x)
-> ParsecState s a -> (ParsecState s b -> x) -> x
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
forall s a b.
Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
runParsector (a -> Parsector s a b
f a
b)) ParsecState s a
fQuery ((ParsecState s b -> x) -> x) -> (ParsecState s b -> x) -> x
forall a b. (a -> b) -> a -> b
$ \ParsecState s b
fReply -> ParsecState s b -> x
callback (ParsecState s b -> x) -> ParsecState s b -> x
forall a b. (a -> b) -> a -> b
$
              if ParsecState s b -> Bool
forall s a. ParsecState s a -> Bool
parsecLooked ParsecState s b
fReply
                then ParsecState s b
fReply
                else ParsecState s b
fReply
                  { parsecLooked = parsecLooked reply
                  , parsecFailure  = hintP <> parsecFailure fReply
                  }
instance Categorized (Item s) => Alternative (Parsector s a) where
  -- | Always fails without consuming input; expects nothing.
  empty :: forall a. Parsector s a a
empty = (forall x. (ParsecState s a -> x) -> ParsecState s a -> x)
-> Parsector s a a
forall s a b.
(forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
Parsector ((forall x. (ParsecState s a -> x) -> ParsecState s a -> x)
 -> Parsector s a a)
-> (forall x. (ParsecState s a -> x) -> ParsecState s a -> x)
-> Parsector s a a
forall a b. (a -> b) -> a -> b
$ \ParsecState s a -> x
callback ParsecState s a
query ->
    ParsecState s a -> x
callback ParsecState s a
query { parsecFailure = mempty, parsecResult = Nothing }
  Parsector s a a
p <|> :: forall a. Parsector s a a -> Parsector s a a -> Parsector s a a
<|> Parsector s a a
q = (forall x. (ParsecState s a -> x) -> ParsecState s a -> x)
-> Parsector s a a
forall s a b.
(forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
Parsector ((forall x. (ParsecState s a -> x) -> ParsecState s a -> x)
 -> Parsector s a a)
-> (forall x. (ParsecState s a -> x) -> ParsecState s a -> x)
-> Parsector s a a
forall a b. (a -> b) -> a -> b
$ \ParsecState s a -> x
callback ParsecState s a
query ->
    ((ParsecState s a -> x) -> ParsecState s a -> x)
-> ParsecState s a -> (ParsecState s a -> x) -> x
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Parsector s a a
-> forall x. (ParsecState s a -> x) -> ParsecState s a -> x
forall s a b.
Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
runParsector Parsector s a a
p) ParsecState s a
query ((ParsecState s a -> x) -> x) -> (ParsecState s a -> x) -> x
forall a b. (a -> b) -> a -> b
$ \ParsecState s a
replyP -> ParsecState s a -> x
callback (ParsecState s a -> x) -> ParsecState s a -> x
forall a b. (a -> b) -> a -> b
$
      case ParsecState s a -> Maybe a
forall s a. ParsecState s a -> Maybe a
parsecResult ParsecState s a
replyP of
        -- if p succeeds, take p's branch
        Just a
_ -> ParsecState s a
replyP
        -- if p failed after consuming (committed), propagate immediately
        Maybe a
Nothing | ParsecState s a -> Bool
forall s a. ParsecState s a -> Bool
parsecLooked ParsecState s a
replyP -> ParsecState s a
replyP
        -- if p failed without consuming, try q
        Maybe a
Nothing ->
          let errP :: ParsecFailure s
errP = ParsecState s a -> ParsecFailure s
forall s a. ParsecState s a -> ParsecFailure s
parsecFailure ParsecState s a
replyP
          in ((ParsecState s a -> ParsecState s a)
 -> ParsecState s a -> ParsecState s a)
-> ParsecState s a
-> (ParsecState s a -> ParsecState s a)
-> ParsecState s a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Parsector s a a
-> forall x. (ParsecState s a -> x) -> ParsecState s a -> x
forall s a b.
Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
runParsector Parsector s a a
q) ParsecState s a
query ((ParsecState s a -> ParsecState s a) -> ParsecState s a)
-> (ParsecState s a -> ParsecState s a) -> ParsecState s a
forall a b. (a -> b) -> a -> b
$ \ParsecState s a
replyQ ->
          case (ParsecState s a -> Bool
forall s a. ParsecState s a -> Bool
parsecLooked ParsecState s a
replyQ, ParsecState s a -> Maybe a
forall s a. ParsecState s a -> Maybe a
parsecResult ParsecState s a
replyQ) of
            -- q consumed (ok or err): propagate as-is, drop errP
            (Bool
True, Maybe a
_)         -> ParsecState s a
replyQ
            -- q empty ok: carry errP forward as hint for downstream
            (Bool
False, Just a
_)   -> ParsecState s a
replyQ { parsecFailure = errP <> parsecFailure replyQ }
            -- both empty fail: merge failures
            (Bool
False, Maybe a
Nothing)  -> ParsecState s a
replyP { parsecFailure = errP <> parsecFailure replyQ }
instance Categorized (Item s) => MonadPlus (Parsector s a)
instance Categorized (Item s) => MonadFail (Parsector s a) where
  fail :: forall a. String -> Parsector s a a
fail String
msg = String -> Parsector s a a -> Parsector s a a
forall bnf. BackusNaurForm bnf => String -> bnf -> bnf
rule String
msg Parsector s a a
forall a. Parsector s a a
forall (f :: * -> *) a. Alternative f => f a
empty
instance Categorized (Item s) => MonadTry (Parsector s a) where
  -- | On failure, resets `parsecLooked` to @False@, allowing
  -- the enclosing `<|>` to try the next alternative even if @p@
  -- consumed input. Also restores the stream/offset decision state.
  -- Has no effect on success.
  try :: forall a. Parsector s a a -> Parsector s a a
try Parsector s a a
p = (forall x. (ParsecState s a -> x) -> ParsecState s a -> x)
-> Parsector s a a
forall s a b.
(forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
Parsector ((forall x. (ParsecState s a -> x) -> ParsecState s a -> x)
 -> Parsector s a a)
-> (forall x. (ParsecState s a -> x) -> ParsecState s a -> x)
-> Parsector s a a
forall a b. (a -> b) -> a -> b
$ \ParsecState s a -> x
callback ParsecState s a
query ->
    ((ParsecState s a -> x) -> ParsecState s a -> x)
-> ParsecState s a -> (ParsecState s a -> x) -> x
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Parsector s a a
-> forall x. (ParsecState s a -> x) -> ParsecState s a -> x
forall s a b.
Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
runParsector Parsector s a a
p) ParsecState s a
query ((ParsecState s a -> x) -> x) -> (ParsecState s a -> x) -> x
forall a b. (a -> b) -> a -> b
$ \ParsecState s a
reply -> ParsecState s a -> x
callback (ParsecState s a -> x) -> ParsecState s a -> x
forall a b. (a -> b) -> a -> b
$
      case ParsecState s a -> Maybe a
forall s a. ParsecState s a -> Maybe a
parsecResult ParsecState s a
reply of
        Maybe a
Nothing -> ParsecState s a
query
          { parsecLooked = False
          , parsecFailure  = parsecFailure reply
          , parsecResult = Nothing
          }
        Just a
_ -> ParsecState s a
reply
instance Categorized (Item s) => Filterable (Parsector s a) where
  mapMaybe :: forall a b. (a -> Maybe b) -> Parsector s a a -> Parsector s a b
mapMaybe = (a -> Maybe a)
-> (a -> Maybe b) -> Parsector s a a -> Parsector s a b
forall (p :: * -> * -> *) s a b t.
(Choice p, Cochoice p) =>
(s -> Maybe a) -> (b -> Maybe t) -> p a b -> p s t
dimapMaybe a -> Maybe a
forall a. a -> Maybe a
Just
instance Category (Parsector s) where
  id :: forall a. Parsector s a a
id = (forall x. (ParsecState s a -> x) -> ParsecState s a -> x)
-> Parsector s a a
forall s a b.
(forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
Parsector (ParsecState s a -> x) -> ParsecState s a -> x
forall a. a -> a
forall x. (ParsecState s a -> x) -> ParsecState s a -> x
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
  Parsector forall x. (ParsecState s c -> x) -> ParsecState s b -> x
q . :: forall b c a. Parsector s b c -> Parsector s a b -> Parsector s a c
. Parsector forall x. (ParsecState s b -> x) -> ParsecState s a -> x
p = (forall x. (ParsecState s c -> x) -> ParsecState s a -> x)
-> Parsector s a c
forall s a b.
(forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
Parsector ((ParsecState s b -> x) -> ParsecState s a -> x
forall x. (ParsecState s b -> x) -> ParsecState s a -> x
p ((ParsecState s b -> x) -> ParsecState s a -> x)
-> ((ParsecState s c -> x) -> ParsecState s b -> x)
-> (ParsecState s c -> x)
-> ParsecState s a
-> x
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (ParsecState s c -> x) -> ParsecState s b -> x
forall x. (ParsecState s c -> x) -> ParsecState s b -> x
q)
instance Categorized (Item s) => Arrow (Parsector s) where
  arr :: forall b c. (b -> c) -> Parsector s b c
arr b -> c
f = (forall x. (ParsecState s c -> x) -> ParsecState s b -> x)
-> Parsector s b c
forall s a b.
(forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
Parsector ((forall x. (ParsecState s c -> x) -> ParsecState s b -> x)
 -> Parsector s b c)
-> (forall x. (ParsecState s c -> x) -> ParsecState s b -> x)
-> Parsector s b c
forall a b. (a -> b) -> a -> b
$ \ParsecState s c -> x
callback ParsecState s b
reply -> ParsecState s c -> x
callback (b -> c
f (b -> c) -> ParsecState s b -> ParsecState s c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecState s b
reply)
  *** :: forall b c b' c'.
Parsector s b c -> Parsector s b' c' -> Parsector s (b, b') (c, c')
(***) = Parsector s b c -> Parsector s b' c' -> Parsector s (b, b') (c, c')
forall (p :: * -> * -> *) a b c d.
Monoidal p =>
p a b -> p c d -> p (a, c) (b, d)
(>*<)
  first :: forall b c d. Parsector s b c -> Parsector s (b, d) (c, d)
first = Parsector s b c -> Parsector s (b, d) (c, d)
forall b c d. Parsector s b c -> Parsector s (b, d) (c, d)
forall (p :: * -> * -> *) a b c.
Strong p =>
p a b -> p (a, c) (b, c)
first'
  second :: forall b c d. Parsector s b c -> Parsector s (d, b) (d, c)
second = Parsector s b c -> Parsector s (d, b) (d, c)
forall b c d. Parsector s b c -> Parsector s (d, b) (d, c)
forall (p :: * -> * -> *) a b c.
Strong p =>
p a b -> p (c, a) (c, b)
second'
instance Categorized (Item s) => ArrowZero (Parsector s) where
  zeroArrow :: forall b c. Parsector s b c
zeroArrow = Parsector s b c
forall a. Parsector s b a
forall (f :: * -> *) a. Alternative f => f a
empty
instance Categorized (Item s) => ArrowPlus (Parsector s) where
  <+> :: forall b c. Parsector s b c -> Parsector s b c -> Parsector s b c
(<+>) = Parsector s b c -> Parsector s b c -> Parsector s b c
forall a. Parsector s b a -> Parsector s b a -> Parsector s b a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)
instance Categorized (Item s) => ArrowChoice (Parsector s) where
  +++ :: forall b c b' c'.
Parsector s b c
-> Parsector s b' c' -> Parsector s (Either b b') (Either c c')
(+++) = Parsector s b c
-> Parsector s b' c' -> Parsector s (Either b b') (Either c c')
forall b c b' c'.
Parsector s b c
-> Parsector s b' c' -> Parsector s (Either b b') (Either c c')
forall (p :: * -> * -> *) a b c d.
Distributor p =>
p a b -> p c d -> p (Either a c) (Either b d)
(>+<)
  left :: forall b c d.
Parsector s b c -> Parsector s (Either b d) (Either c d)
left = Parsector s b c -> Parsector s (Either b d) (Either c d)
forall b c d.
Parsector s b c -> Parsector s (Either b d) (Either c d)
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either a c) (Either b c)
left'
  right :: forall b c d.
Parsector s b c -> Parsector s (Either d b) (Either d c)
right = Parsector s b c -> Parsector s (Either d b) (Either d c)
forall b c d.
Parsector s b c -> Parsector s (Either d b) (Either d c)
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right'
instance Profunctor (Parsector s) where
  dimap :: forall a b c d.
(a -> b) -> (c -> d) -> Parsector s b c -> Parsector s a d
dimap a -> b
f c -> d
g (Parsector forall x. (ParsecState s c -> x) -> ParsecState s b -> x
p) = (forall x. (ParsecState s d -> x) -> ParsecState s a -> x)
-> Parsector s a d
forall s a b.
(forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
Parsector ((forall x. (ParsecState s d -> x) -> ParsecState s a -> x)
 -> Parsector s a d)
-> (forall x. (ParsecState s d -> x) -> ParsecState s a -> x)
-> Parsector s a d
forall a b. (a -> b) -> a -> b
$
    ((ParsecState s d -> x) -> ParsecState s c -> x)
-> ((ParsecState s b -> x) -> ParsecState s a -> x)
-> ((ParsecState s c -> x) -> ParsecState s b -> x)
-> (ParsecState s d -> x)
-> ParsecState s a
-> x
forall a b c d. (a -> b) -> (c -> d) -> (b -> c) -> a -> d
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap ((ParsecState s c -> ParsecState s d)
-> (ParsecState s d -> x) -> ParsecState s c -> x
forall a b c. (a -> b) -> (b -> c) -> a -> c
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap ((c -> d) -> ParsecState s c -> ParsecState s d
forall a b. (a -> b) -> ParsecState s a -> ParsecState s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g)) ((ParsecState s a -> ParsecState s b)
-> (ParsecState s b -> x) -> ParsecState s a -> x
forall a b c. (a -> b) -> (b -> c) -> a -> c
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap ((a -> b) -> ParsecState s a -> ParsecState s b
forall a b. (a -> b) -> ParsecState s a -> ParsecState s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f)) (ParsecState s c -> x) -> ParsecState s b -> x
forall x. (ParsecState s c -> x) -> ParsecState s b -> x
p
instance Strong (Parsector s) where
  first' :: forall a b c. Parsector s a b -> Parsector s (a, c) (b, c)
first' Parsector s a b
p = (forall x.
 (ParsecState s (b, c) -> x) -> ParsecState s (a, c) -> x)
-> Parsector s (a, c) (b, c)
forall s a b.
(forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
Parsector ((forall x.
  (ParsecState s (b, c) -> x) -> ParsecState s (a, c) -> x)
 -> Parsector s (a, c) (b, c))
-> (forall x.
    (ParsecState s (b, c) -> x) -> ParsecState s (a, c) -> x)
-> Parsector s (a, c) (b, c)
forall a b. (a -> b) -> a -> b
$ \ParsecState s (b, c) -> x
callback ParsecState s (a, c)
reply0 ->
    ((ParsecState s b -> x) -> ParsecState s a -> x)
-> ParsecState s a -> (ParsecState s b -> x) -> x
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
forall s a b.
Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
runParsector Parsector s a b
p) ((a, c) -> a
forall a b. (a, b) -> a
fst ((a, c) -> a) -> ParsecState s (a, c) -> ParsecState s a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecState s (a, c)
reply0) ((ParsecState s b -> x) -> x) -> (ParsecState s b -> x) -> x
forall a b. (a -> b) -> a -> b
$ \ParsecState s b
reply1 ->
      ParsecState s (b, c) -> x
callback ParsecState s b
reply1
        { parsecResult = (,)
            <$> parsecResult reply1
            <*> (snd <$> parsecResult reply0)
        }
  second' :: forall a b c. Parsector s a b -> Parsector s (c, a) (c, b)
second' Parsector s a b
p = (forall x.
 (ParsecState s (c, b) -> x) -> ParsecState s (c, a) -> x)
-> Parsector s (c, a) (c, b)
forall s a b.
(forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
Parsector ((forall x.
  (ParsecState s (c, b) -> x) -> ParsecState s (c, a) -> x)
 -> Parsector s (c, a) (c, b))
-> (forall x.
    (ParsecState s (c, b) -> x) -> ParsecState s (c, a) -> x)
-> Parsector s (c, a) (c, b)
forall a b. (a -> b) -> a -> b
$ \ParsecState s (c, b) -> x
callback ParsecState s (c, a)
reply0 ->
    ((ParsecState s b -> x) -> ParsecState s a -> x)
-> ParsecState s a -> (ParsecState s b -> x) -> x
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
forall s a b.
Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
runParsector Parsector s a b
p) ((c, a) -> a
forall a b. (a, b) -> b
snd ((c, a) -> a) -> ParsecState s (c, a) -> ParsecState s a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecState s (c, a)
reply0) ((ParsecState s b -> x) -> x) -> (ParsecState s b -> x) -> x
forall a b. (a -> b) -> a -> b
$ \ParsecState s b
reply1 ->
      ParsecState s (c, b) -> x
callback ParsecState s b
reply1
        { parsecResult = (,)
            <$> (fst <$> parsecResult reply0)
            <*> parsecResult reply1
        }
instance Categorized (Item s) => Choice (Parsector s) where
  left' :: forall a b c.
Parsector s a b -> Parsector s (Either a c) (Either b c)
left' = Either (Parsector s a b) (Parsector s c c)
-> Parsector s (Either a c) (Either b c)
forall a b c d.
Either (Parsector s a b) (Parsector s c d)
-> Parsector s (Either a c) (Either b d)
forall (p :: * -> * -> *) a b c d.
Alternator p =>
Either (p a b) (p c d) -> p (Either a c) (Either b d)
alternate (Either (Parsector s a b) (Parsector s c c)
 -> Parsector s (Either a c) (Either b c))
-> (Parsector s a b -> Either (Parsector s a b) (Parsector s c c))
-> Parsector s a b
-> Parsector s (Either a c) (Either b c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Parsector s a b -> Either (Parsector s a b) (Parsector s c c)
forall a b. a -> Either a b
Left
  right' :: forall a b c.
Parsector s a b -> Parsector s (Either c a) (Either c b)
right' = Either (Parsector s c c) (Parsector s a b)
-> Parsector s (Either c a) (Either c b)
forall a b c d.
Either (Parsector s a b) (Parsector s c d)
-> Parsector s (Either a c) (Either b d)
forall (p :: * -> * -> *) a b c d.
Alternator p =>
Either (p a b) (p c d) -> p (Either a c) (Either b d)
alternate (Either (Parsector s c c) (Parsector s a b)
 -> Parsector s (Either c a) (Either c b))
-> (Parsector s a b -> Either (Parsector s c c) (Parsector s a b))
-> Parsector s a b
-> Parsector s (Either c a) (Either c b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Parsector s a b -> Either (Parsector s c c) (Parsector s a b)
forall a b. b -> Either a b
Right
instance Categorized (Item s) => Distributor (Parsector s)
instance Categorized (Item s) => Alternator (Parsector s) where
  alternate :: forall a b c d.
Either (Parsector s a b) (Parsector s c d)
-> Parsector s (Either a c) (Either b d)
alternate (Left Parsector s a b
p) = (forall x.
 (ParsecState s (Either b d) -> x)
 -> ParsecState s (Either a c) -> x)
-> Parsector s (Either a c) (Either b d)
forall s a b.
(forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
Parsector ((forall x.
  (ParsecState s (Either b d) -> x)
  -> ParsecState s (Either a c) -> x)
 -> Parsector s (Either a c) (Either b d))
-> (forall x.
    (ParsecState s (Either b d) -> x)
    -> ParsecState s (Either a c) -> x)
-> Parsector s (Either a c) (Either b d)
forall a b. (a -> b) -> a -> b
$ \ParsecState s (Either b d) -> x
callback ParsecState s (Either a c)
query -> ParsecState s (Either b d) -> x
callback (ParsecState s (Either b d) -> x)
-> ParsecState s (Either b d) -> x
forall a b. (a -> b) -> a -> b
$
    let
      replyOk :: ParsecState s a
replyOk = ParsecState s (Either a c)
query
        { parsecResult = case parsecResult query of
            Maybe (Either a c)
Nothing         -> Maybe a
forall a. Maybe a
Nothing
            Just (Left a
a)   -> a -> Maybe a
forall a. a -> Maybe a
Just a
a
            Just (Right c
_)  -> Maybe a
forall a. Maybe a
Nothing
        }
      replyErr :: ParsecState s (Either b d)
replyErr = ParsecState s (Either a c)
query { parsecFailure = mempty, parsecResult = Nothing }
    in
      case (ParsecState s (Either a c) -> Maybe (Either a c)
forall s a. ParsecState s a -> Maybe a
parsecResult ParsecState s (Either a c)
query, ParsecState s a -> Maybe a
forall s a. ParsecState s a -> Maybe a
parsecResult ParsecState s a
replyOk) of
        (Just Either a c
_, Maybe a
Nothing) -> ParsecState s (Either b d)
replyErr
        (Maybe (Either a c), Maybe a)
_________________ ->
          ((ParsecState s b -> ParsecState s (Either b d))
 -> ParsecState s a -> ParsecState s (Either b d))
-> ParsecState s a
-> (ParsecState s b -> ParsecState s (Either b d))
-> ParsecState s (Either b d)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
forall s a b.
Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
runParsector Parsector s a b
p) ParsecState s a
replyOk ((ParsecState s b -> ParsecState s (Either b d))
 -> ParsecState s (Either b d))
-> (ParsecState s b -> ParsecState s (Either b d))
-> ParsecState s (Either b d)
forall a b. (a -> b) -> a -> b
$ \ParsecState s b
reply -> ParsecState s b
reply
            { parsecResult = fmap Left (parsecResult reply) }
  alternate (Right Parsector s c d
p) = (forall x.
 (ParsecState s (Either b d) -> x)
 -> ParsecState s (Either a c) -> x)
-> Parsector s (Either a c) (Either b d)
forall s a b.
(forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
Parsector ((forall x.
  (ParsecState s (Either b d) -> x)
  -> ParsecState s (Either a c) -> x)
 -> Parsector s (Either a c) (Either b d))
-> (forall x.
    (ParsecState s (Either b d) -> x)
    -> ParsecState s (Either a c) -> x)
-> Parsector s (Either a c) (Either b d)
forall a b. (a -> b) -> a -> b
$ \ParsecState s (Either b d) -> x
callback ParsecState s (Either a c)
query -> ParsecState s (Either b d) -> x
callback (ParsecState s (Either b d) -> x)
-> ParsecState s (Either b d) -> x
forall a b. (a -> b) -> a -> b
$
    let
      replyOk :: ParsecState s c
replyOk = ParsecState s (Either a c)
query
        { parsecResult = case parsecResult query of
            Maybe (Either a c)
Nothing         -> Maybe c
forall a. Maybe a
Nothing
            Just (Left a
_)   -> Maybe c
forall a. Maybe a
Nothing
            Just (Right c
b)  -> c -> Maybe c
forall a. a -> Maybe a
Just c
b
        }
      replyErr :: ParsecState s (Either b d)
replyErr = ParsecState s (Either a c)
query { parsecFailure = mempty, parsecResult = Nothing }
    in
      case (ParsecState s (Either a c) -> Maybe (Either a c)
forall s a. ParsecState s a -> Maybe a
parsecResult ParsecState s (Either a c)
query, ParsecState s c -> Maybe c
forall s a. ParsecState s a -> Maybe a
parsecResult ParsecState s c
replyOk) of
        (Just Either a c
_, Maybe c
Nothing) -> ParsecState s (Either b d)
replyErr
        (Maybe (Either a c), Maybe c)
_________________ ->
          ((ParsecState s d -> ParsecState s (Either b d))
 -> ParsecState s c -> ParsecState s (Either b d))
-> ParsecState s c
-> (ParsecState s d -> ParsecState s (Either b d))
-> ParsecState s (Either b d)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Parsector s c d
-> forall x. (ParsecState s d -> x) -> ParsecState s c -> x
forall s a b.
Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
runParsector Parsector s c d
p) ParsecState s c
replyOk ((ParsecState s d -> ParsecState s (Either b d))
 -> ParsecState s (Either b d))
-> (ParsecState s d -> ParsecState s (Either b d))
-> ParsecState s (Either b d)
forall a b. (a -> b) -> a -> b
$ \ParsecState s d
reply -> ParsecState s d
reply
            { parsecResult = fmap Right (parsecResult reply) }
  optionP :: forall a b. APrism a b () () -> Parsector s a b -> Parsector s a b
optionP APrism a b () ()
def Parsector s a b
p = (forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
forall s a b.
(forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
Parsector ((forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
 -> Parsector s a b)
-> (forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
forall a b. (a -> b) -> a -> b
$ \ParsecState s b -> x
callback ParsecState s a
query ->
    case ParsecState s a -> Maybe a
forall s a. ParsecState s a -> Maybe a
parsecResult ParsecState s a
query of
      Maybe a
Nothing -> Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
forall s a b.
Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
runParsector (Parsector s a b
p Parsector s a b -> Parsector s a b -> Parsector s a b
forall a. Parsector s a a -> Parsector s a a -> Parsector s a a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> APrism a b () () -> Parsector s a b
forall (p :: * -> * -> *) a b.
(Monoidal p, Choice p) =>
APrism a b () () -> p a b
pureP APrism a b () ()
def) ParsecState s b -> x
callback ParsecState s a
query
      Just a
_ -> Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
forall s a b.
Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
runParsector (APrism a b () () -> Parsector s a b
forall (p :: * -> * -> *) a b.
(Monoidal p, Choice p) =>
APrism a b () () -> p a b
pureP APrism a b () ()
def Parsector s a b -> Parsector s a b -> Parsector s a b
forall a. Parsector s a a -> Parsector s a a -> Parsector s a a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsector s a b
p) ParsecState s b -> x
callback ParsecState s a
query
instance Categorized (Item s) => Cochoice (Parsector s) where
  unleft :: forall a d b.
Parsector s (Either a d) (Either b d) -> Parsector s a b
unleft = (Parsector s a b, Parsector s d d) -> Parsector s a b
forall a b. (a, b) -> a
fst ((Parsector s a b, Parsector s d d) -> Parsector s a b)
-> (Parsector s (Either a d) (Either b d)
    -> (Parsector s a b, Parsector s d d))
-> Parsector s (Either a d) (Either b d)
-> Parsector s a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Parsector s (Either a d) (Either b d)
-> (Parsector s a b, Parsector s d d)
forall a c b d.
Parsector s (Either a c) (Either b d)
-> (Parsector s a b, Parsector s c d)
forall (p :: * -> * -> *) a c b d.
Filtrator p =>
p (Either a c) (Either b d) -> (p a b, p c d)
filtrate
  unright :: forall d a b.
Parsector s (Either d a) (Either d b) -> Parsector s a b
unright = (Parsector s d d, Parsector s a b) -> Parsector s a b
forall a b. (a, b) -> b
snd ((Parsector s d d, Parsector s a b) -> Parsector s a b)
-> (Parsector s (Either d a) (Either d b)
    -> (Parsector s d d, Parsector s a b))
-> Parsector s (Either d a) (Either d b)
-> Parsector s a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Parsector s (Either d a) (Either d b)
-> (Parsector s d d, Parsector s a b)
forall a c b d.
Parsector s (Either a c) (Either b d)
-> (Parsector s a b, Parsector s c d)
forall (p :: * -> * -> *) a c b d.
Filtrator p =>
p (Either a c) (Either b d) -> (p a b, p c d)
filtrate
instance Categorized (Item s) => Filtrator (Parsector s) where
  filtrate :: forall a c b d.
Parsector s (Either a c) (Either b d)
-> (Parsector s a b, Parsector s c d)
filtrate Parsector s (Either a c) (Either b d)
p =
    ( (forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
forall s a b.
(forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
Parsector ((forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
 -> Parsector s a b)
-> (forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
forall a b. (a -> b) -> a -> b
$ \ParsecState s b -> x
callback ParsecState s a
query ->
        ((ParsecState s (Either b d) -> x)
 -> ParsecState s (Either a c) -> x)
-> ParsecState s (Either a c)
-> (ParsecState s (Either b d) -> x)
-> x
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Parsector s (Either a c) (Either b d)
-> forall x.
   (ParsecState s (Either b d) -> x)
   -> ParsecState s (Either a c) -> x
forall s a b.
Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
runParsector Parsector s (Either a c) (Either b d)
p) (a -> Either a c
forall a b. a -> Either a b
Left (a -> Either a c) -> ParsecState s a -> ParsecState s (Either a c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecState s a
query) ((ParsecState s (Either b d) -> x) -> x)
-> (ParsecState s (Either b d) -> x) -> x
forall a b. (a -> b) -> a -> b
$ \ParsecState s (Either b d)
reply ->
          ParsecState s b -> x
callback ParsecState s (Either b d)
reply
          { parsecFailure = case parsecResult reply of
            Just (Right d
_) -> ParsecFailure s
forall a. Monoid a => a
mempty
            Maybe (Either b d)
_ -> ParsecState s (Either b d) -> ParsecFailure s
forall s a. ParsecState s a -> ParsecFailure s
parsecFailure ParsecState s (Either b d)
reply
          , parsecResult =
            parsecResult reply >>= either Just (const Nothing)
          }
    , (forall x. (ParsecState s d -> x) -> ParsecState s c -> x)
-> Parsector s c d
forall s a b.
(forall x. (ParsecState s b -> x) -> ParsecState s a -> x)
-> Parsector s a b
Parsector ((forall x. (ParsecState s d -> x) -> ParsecState s c -> x)
 -> Parsector s c d)
-> (forall x. (ParsecState s d -> x) -> ParsecState s c -> x)
-> Parsector s c d
forall a b. (a -> b) -> a -> b
$ \ParsecState s d -> x
callback ParsecState s c
query ->
        ((ParsecState s (Either b d) -> x)
 -> ParsecState s (Either a c) -> x)
-> ParsecState s (Either a c)
-> (ParsecState s (Either b d) -> x)
-> x
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Parsector s (Either a c) (Either b d)
-> forall x.
   (ParsecState s (Either b d) -> x)
   -> ParsecState s (Either a c) -> x
forall s a b.
Parsector s a b
-> forall x. (ParsecState s b -> x) -> ParsecState s a -> x
runParsector Parsector s (Either a c) (Either b d)
p) (c -> Either a c
forall a b. b -> Either a b
Right (c -> Either a c) -> ParsecState s c -> ParsecState s (Either a c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecState s c
query) ((ParsecState s (Either b d) -> x) -> x)
-> (ParsecState s (Either b d) -> x) -> x
forall a b. (a -> b) -> a -> b
$ \ParsecState s (Either b d)
reply ->
          ParsecState s d -> x
callback ParsecState s (Either b d)
reply
          { parsecFailure = case parsecResult reply of
            Just (Left b
_) -> ParsecFailure s
forall a. Monoid a => a
mempty
            Maybe (Either b d)
_ -> ParsecState s (Either b d) -> ParsecFailure s
forall s a. ParsecState s a -> ParsecFailure s
parsecFailure ParsecState s (Either b d)
reply
          , parsecResult =
            parsecResult reply >>= either (const Nothing) Just
          }
    )