    -- Author: Malcolm Wallace

    -- | In a strict language, where creating the entire input list of tokens
    --   in one shot may be infeasible, we can use a lazy "callback" kind of
    --   architecture instead.  The lexer returns a single token at a time,
    --   together with a continuation.
    --
    --   This module defines a Parser type (capable of use with the Poly
    --   combinators), specialised to the callback-lexer style of input stream.

    module Text.ParserCombinators.Poly.Lex
      ( -- * The Parser datatype
        LexReturn(..)
      , Parser(P)
      , Result(..)
      , runParser
        -- ** Basic parsers
      , next
      , eof
      , satisfy
      , onFail
        -- ** Re-parsing
      , reparse
        -- * Re-export all more general combinators
      , module Text.ParserCombinators.Poly.Base
      , module Control.Applicative
      ) where

    import Text.ParserCombinators.Poly.Base
    import Text.ParserCombinators.Poly.Result
    import Control.Applicative
    import qualified Control.Monad.Fail as Fail

    -- | In a strict language, where creating the entire input list of tokens
    --   in one shot may be infeasible, we can use a lazy "callback" kind of
    --   architecture instead.  The lexer returns a single token at a time,
    --   together with a continuation.  The @next@ parser is responsible for
    --   pulling on the token stream, applying the continuation where necessary.
    data LexReturn t = LexReturn t String (String->LexReturn t)
                     | LexFinish

    -- | This @Parser@ datatype is a specialised parsing monad with error
    --   reporting.  This version is specialised to pre-lexed String input,
    --   where the lexer has been written to yield a @LexReturn@.
    newtype Parser t a = P (LexReturn t -> Result (LexReturn t) a)

    -- | Apply a parser to an input token sequence.
    runParser :: Parser t a -> LexReturn t -> (Either String a, String)
    runParser :: forall t a. Parser t a -> LexReturn t -> (Either String a, String)
    runParser (P LexReturn t -> Result (LexReturn t) a
    p) = (\ (Either String a
    a,LexReturn t
    b)->(Either String a
    a,LexReturn t -> String
    forall {t}. LexReturn t -> String
    stripLex LexReturn t
    b)) ((Either String a, LexReturn t) -> (Either String a, String))
    -> (LexReturn t -> (Either String a, LexReturn t))
    -> LexReturn t
    -> (Either String a, String)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Result (LexReturn t) a -> (Either String a, LexReturn t)
    forall z a. Result z a -> (Either String a, z)
    resultToEither (Result (LexReturn t) a -> (Either String a, LexReturn t))
    -> (LexReturn t -> Result (LexReturn t) a)
    -> LexReturn t
    -> (Either String a, LexReturn t)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . LexReturn t -> Result (LexReturn t) a
    p
      where stripLex :: LexReturn t -> String
    stripLex  LexReturn t
    LexFinish        = String
    ""
            stripLex (LexReturn t
    _ String
    s String -> LexReturn t
    _) = String
    s

    instance Functor (Parser t) where
        fmap :: forall a b. (a -> b) -> Parser t a -> Parser t b
    fmap a -> b
    f (P LexReturn t -> Result (LexReturn t) a
    p) = (LexReturn t -> Result (LexReturn t) b) -> Parser t b
    forall t a. (LexReturn t -> Result (LexReturn t) a) -> Parser t a
    P ((a -> b) -> Result (LexReturn t) a -> Result (LexReturn t) b
    forall a b.
    (a -> b) -> Result (LexReturn t) a -> Result (LexReturn t) b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap a -> b
    f (Result (LexReturn t) a -> Result (LexReturn t) b)
    -> (LexReturn t -> Result (LexReturn t) a)
    -> LexReturn t
    -> Result (LexReturn t) b
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . LexReturn t -> Result (LexReturn t) a
    p)

    instance Monad (Parser t) where
        return :: forall a. a -> Parser t a
    return       = a -> Parser t a
    forall a. a -> Parser t a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure
        (P LexReturn t -> Result (LexReturn t) a
    f) >>= :: forall a b. Parser t a -> (a -> Parser t b) -> Parser t b
    >>= a -> Parser t b
    g  = (LexReturn t -> Result (LexReturn t) b) -> Parser t b
    forall t a. (LexReturn t -> Result (LexReturn t) a) -> Parser t a
    P (Result (LexReturn t) a -> Result (LexReturn t) b
    continue (Result (LexReturn t) a -> Result (LexReturn t) b)
    -> (LexReturn t -> Result (LexReturn t) a)
    -> LexReturn t
    -> Result (LexReturn t) b
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . LexReturn t -> Result (LexReturn t) a
    f)
          where
            continue :: Result (LexReturn t) a -> Result (LexReturn t) b
    continue (Success LexReturn t
    ts a
    x)             = let (P LexReturn t -> Result (LexReturn t) b
    g') = a -> Parser t b
    g a
    x in LexReturn t -> Result (LexReturn t) b
    g' LexReturn t
    ts
            continue (Committed Result (LexReturn t) a
    r)              = Result (LexReturn t) b -> Result (LexReturn t) b
    forall z a. Result z a -> Result z a
    Committed (Result (LexReturn t) a -> Result (LexReturn t) b
    continue Result (LexReturn t) a
    r)
            continue (Failure LexReturn t
    ts String
    e)             = LexReturn t -> String -> Result (LexReturn t) b
    forall z a. z -> String -> Result z a
    Failure LexReturn t
    ts String
    e

    #if !MIN_VERSION_base(4,13,0)
        fail         = Fail.fail
    #endif

    instance Fail.MonadFail  (Parser t) where
        fail :: forall a. String -> Parser t a
    fail String
    e       = (LexReturn t -> Result (LexReturn t) a) -> Parser t a
    forall t a. (LexReturn t -> Result (LexReturn t) a) -> Parser t a
    P (\LexReturn t
    ts-> LexReturn t -> String -> Result (LexReturn t) a
    forall z a. z -> String -> Result z a
    Failure LexReturn t
    ts String
    e)

    instance Commitment (Parser t) where
        commit :: forall a. Parser t a -> Parser t a
    commit (P LexReturn t -> Result (LexReturn t) a
    p)         = (LexReturn t -> Result (LexReturn t) a) -> Parser t a
    forall t a. (LexReturn t -> Result (LexReturn t) a) -> Parser t a
    P (Result (LexReturn t) a -> Result (LexReturn t) a
    forall z a. Result z a -> Result z a
    Committed (Result (LexReturn t) a -> Result (LexReturn t) a)
    -> (LexReturn t -> Result (LexReturn t) a)
    -> LexReturn t
    -> Result (LexReturn t) a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Result (LexReturn t) a -> Result (LexReturn t) a
    forall z a. Result z a -> Result z a
    squash (Result (LexReturn t) a -> Result (LexReturn t) a)
    -> (LexReturn t -> Result (LexReturn t) a)
    -> LexReturn t
    -> Result (LexReturn t) a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . LexReturn t -> Result (LexReturn t) a
    p)
          where
            squash :: Result z a -> Result z a
    squash (Committed Result z a
    r) = Result z a -> Result z a
    squash Result z a
    r
            squash Result z a
    r             = Result z a
    r
        (P LexReturn t -> Result (LexReturn t) a
    p) adjustErr :: forall a. Parser t a -> (String -> String) -> Parser t a
    `adjustErr` String -> String
    f  = (LexReturn t -> Result (LexReturn t) a) -> Parser t a
    forall t a. (LexReturn t -> Result (LexReturn t) a) -> Parser t a
    P (Result (LexReturn t) a -> Result (LexReturn t) a
    forall z a. Result z a -> Result z a
    adjust (Result (LexReturn t) a -> Result (LexReturn t) a)
    -> (LexReturn t -> Result (LexReturn t) a)
    -> LexReturn t
    -> Result (LexReturn t) a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . LexReturn t -> Result (LexReturn t) a
    p)
          where
            adjust :: Result z a -> Result z a
    adjust (Failure z
    z String
    e) = z -> String -> Result z a
    forall z a. z -> String -> Result z a
    Failure z
    z (String -> String
    f String
    e)
            adjust (Committed Result z a
    r) = Result z a -> Result z a
    forall z a. Result z a -> Result z a
    Committed (Result z a -> Result z a
    adjust Result z a
    r)
            adjust  Result z a
    good         = Result z a
    good

        oneOf' :: forall a. [(String, Parser t a)] -> Parser t a
    oneOf' = [(String, String)] -> [(String, Parser t a)] -> Parser t a
    forall {t} {a}.
    [(String, String)] -> [(String, Parser t a)] -> Parser t a
    accum []
          where accum :: [(String, String)] -> [(String, Parser t a)] -> Parser t a
    accum [(String, String)]
    errs [] =
                    String -> Parser t a
    forall a. String -> Parser t a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String
    "failed to parse any of the possible choices:\n"
                         String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++(Int -> String -> String
    indent Int
    2 (String -> String)
    -> ([(String, String)] -> String) -> [(String, String)] -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [String] -> String
    unlines ([String] -> String)
    -> ([(String, String)] -> [String]) -> [(String, String)] -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((String, String) -> String) -> [(String, String)] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (String, String) -> String
    showErr ([(String, String)] -> [String])
    -> ([(String, String)] -> [(String, String)])
    -> [(String, String)]
    -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [(String, String)] -> [(String, String)]
    forall a. [a] -> [a]
    reverse ([(String, String)] -> String) -> [(String, String)] -> String
    forall a b. (a -> b) -> a -> b
    $ [(String, String)]
    errs))
                accum [(String, String)]
    errs ((String
    e,P LexReturn t -> Result (LexReturn t) a
    p):[(String, Parser t a)]
    ps) =
                    (LexReturn t -> Result (LexReturn t) a) -> Parser t a
    forall t a. (LexReturn t -> Result (LexReturn t) a) -> Parser t a
    P (\LexReturn t
    ts-> case LexReturn t -> Result (LexReturn t) a
    p LexReturn t
    ts of
                               Failure LexReturn t
    _ String
    err ->
                                           let (P LexReturn t -> Result (LexReturn t) a
    p') = [(String, String)] -> [(String, Parser t a)] -> Parser t a
    accum ((String
    e,String
    err)(String, String) -> [(String, String)] -> [(String, String)]
    forall a. a -> [a] -> [a]
    :[(String, String)]
    errs) [(String, Parser t a)]
    ps
                                           in LexReturn t -> Result (LexReturn t) a
    p' LexReturn t
    ts
                               r :: Result (LexReturn t) a
    r@(Success LexReturn t
    _ a
    _)    -> Result (LexReturn t) a
    r
                               r :: Result (LexReturn t) a
    r@(Committed Result (LexReturn t) a
    _)    -> Result (LexReturn t) a
    r )
                showErr :: (String, String) -> String
    showErr (String
    name,String
    err) = String
    name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String -> String
    indent Int
    2 String
    err

    infixl 6 `onFail`       -- not sure about precedence 6?

    -- | @p `onFail` q@ means parse p, unless p fails, in which case
    --   parse q instead.
    --   Can be chained together to give multiple attempts to parse something.
    --   (Note that q could itself be a failing parser, e.g. to change the error
    --   message from that defined in p to something different.)
    --   However, a severe failure in p cannot be ignored.
    (P LexReturn t -> Result (LexReturn t) a
    p) onFail :: Parser t a -> Parser t a -> Parser t a
    `onFail` (P LexReturn t -> Result (LexReturn t) a
    q) = (LexReturn t -> Result (LexReturn t) a) -> Parser t a
    forall t a. (LexReturn t -> Result (LexReturn t) a) -> Parser t a
    P (\LexReturn t
    ts-> LexReturn t -> Result (LexReturn t) a -> Result (LexReturn t) a
    continue LexReturn t
    ts (Result (LexReturn t) a -> Result (LexReturn t) a)
    -> Result (LexReturn t) a -> Result (LexReturn t) a
    forall a b. (a -> b) -> a -> b
    $ LexReturn t -> Result (LexReturn t) a
    p LexReturn t
    ts)
          where
            continue :: LexReturn t -> Result (LexReturn t) a -> Result (LexReturn t) a
    continue LexReturn t
    ts (Failure LexReturn t
    _ String
    _) = LexReturn t -> Result (LexReturn t) a
    q LexReturn t
    ts
        --  continue _  (Committed r) = r    -- no, remain Committed
            continue LexReturn t
    _  Result (LexReturn t) a
    r             = Result (LexReturn t) a
    r

    instance Applicative (Parser t) where
        pure :: forall a. a -> Parser t a
    pure a
    x    = (LexReturn t -> Result (LexReturn t) a) -> Parser t a
    forall t a. (LexReturn t -> Result (LexReturn t) a) -> Parser t a
    P (\LexReturn t
    ts-> LexReturn t -> a -> Result (LexReturn t) a
    forall z a. z -> a -> Result z a
    Success LexReturn t
    ts a
    x)
        Parser t (a -> b)
    pf <*> :: forall a b. Parser t (a -> b) -> Parser t a -> Parser t b
    <*> Parser t a
    px = do { f <- Parser t (a -> b)
    pf; x <- px; return (f x) }
    #if defined(GLASGOW_HASKELL) && GLASGOW_HASKELL > 610
        p  <*  q  = p `discard` q
    #endif

    instance Alternative (Parser t) where
        empty :: forall a. Parser t a
    empty     = String -> Parser t a
    forall a. String -> Parser t a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "no parse"
        Parser t a
    p <|> :: forall a. Parser t a -> Parser t a -> Parser t a
    <|> Parser t a
    q   = Parser t a
    p Parser t a -> Parser t a -> Parser t a
    forall t a. Parser t a -> Parser t a -> Parser t a
    `onFail` Parser t a
    q

    instance PolyParse (Parser t)

    ------------------------------------------------------------------------

    -- | Simply return the next token in the input tokenstream.
    next :: Parser t t
    next :: forall t. Parser t t
    next = (LexReturn t -> Result (LexReturn t) t) -> Parser t t
    forall t a. (LexReturn t -> Result (LexReturn t) a) -> Parser t a
    P (\LexReturn t
    ts-> case LexReturn t
    ts of
                      LexReturn t
    LexFinish       -> LexReturn t -> String -> Result (LexReturn t) t
    forall z a. z -> String -> Result z a
    Failure LexReturn t
    ts String
    "Ran out of input (EOF)"
                      LexReturn t
    t String
    s String -> LexReturn t
    k -> LexReturn t -> t -> Result (LexReturn t) t
    forall z a. z -> a -> Result z a
    Success (String -> LexReturn t
    k String
    s) t
    t)

    -- | Succeed if the end of file/input has been reached, fail otherwise.
    eof :: Parser t ()
    eof :: forall t. Parser t ()
    eof = (LexReturn t -> Result (LexReturn t) ()) -> Parser t ()
    forall t a. (LexReturn t -> Result (LexReturn t) a) -> Parser t a
    P (\LexReturn t
    ts -> case LexReturn t
    ts of
                      LexReturn t
    LexFinish       -> LexReturn t -> () -> Result (LexReturn t) ()
    forall z a. z -> a -> Result z a
    Success LexReturn t
    ts ()
                      LexReturn t
    _ String
    _ String -> LexReturn t
    _ -> LexReturn t -> String -> Result (LexReturn t) ()
    forall z a. z -> String -> Result z a
    Failure LexReturn t
    ts String
    "Expected end of input (EOF)" )

    -- | Return the next token if it satisfies the given predicate.
    satisfy :: (t -> Bool) -> Parser t t
    satisfy :: forall t. (t -> Bool) -> Parser t t
    satisfy t -> Bool
    f = do { x <- Parser t t
    forall t. Parser t t
    next
                   ; if f x then return x else fail "Parse.satisfy: failed"
                   }

    ------------------------------------------------------------------------
    -- | Push some tokens back onto the front of the input stream and reparse.
    --   This is useful e.g. for recursively expanding macros.  When the
    --   user-parser recognises a macro use, it can lookup the macro
    --   expansion from the parse state, lex it, and then stuff the
    --   lexed expansion back down into the parser.
    reparse    :: [t] -> Parser t ()
    reparse :: forall t. [t] -> Parser t ()
    reparse [t]
    ts  = (LexReturn t -> Result (LexReturn t) ()) -> Parser t ()
    forall t a. (LexReturn t -> Result (LexReturn t) a) -> Parser t a
    P (\LexReturn t
    inp-> LexReturn t -> () -> Result (LexReturn t) ()
    forall z a. z -> a -> Result z a
    Success ([t]
    ts [t] -> LexReturn t -> LexReturn t
    forall {t}. [t] -> LexReturn t -> LexReturn t
    `prefix` LexReturn t
    inp) ())
      where
        (t
    t:[t]
    ts) prefix :: [t] -> LexReturn t -> LexReturn t
    `prefix` LexReturn t
    k = t -> String -> (String -> LexReturn t) -> LexReturn t
    forall t. t -> String -> (String -> LexReturn t) -> LexReturn t
    LexReturn t
    t String
    "" (LexReturn t -> String -> LexReturn t
    forall a b. a -> b -> a
    const ([t]
    ts [t] -> LexReturn t -> LexReturn t
    `prefix` LexReturn t
    k))
        []     `prefix` LexReturn t
    k = LexReturn t
    k

    ------------------------------------------------------------------------