    {-# LANGUAGE CPP                 #-}
    {-# LANGUAGE GADTs               #-}
    {-# LANGUAGE RankNTypes          #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE TypeOperators       #-}
    {-# LANGUAGE DeriveFunctor       #-}

    -- TODO:
    -- better interface
    -- have error messages in the right order
    -- have a message for plain failures as well / remove failure in recoveries

    -- Optimize profile info (no more Ints)

    module Parser.Incremental (Process,
                               recoverWith, symbol, eof, lookNext, testNext, run,
                               mkProcess, profile, pushSyms, pushEof, evalL, evalR, feedZ,
                               Parser(Look, Enter, Yuck), countWidth, fullLog, LogEntry(..),
                               evalL'
                              ) where

    import Control.Arrow       (first, second, (***))
    import Control.Applicative (Alternative ((<|>), empty))
    import qualified Control.Monad.Fail as Fail
    import Data.Tree           (Tree (Node))

    data a :< b = (:<) {forall a b. (a :< b) -> a
    top :: a, forall a b. (a :< b) -> b
    _rest :: b}
    infixr :<

    -- | Parser specification
    data Parser s a where
        Pure  :: a                               -> Parser s a
        Appl  :: Parser s (b -> a) -> Parser s b -> Parser s a

        Bind  :: Parser s a -> (a -> Parser s b) -> Parser s b

        Look  :: Parser s a -> (s -> Parser s a) -> Parser s a
        Shif  :: Parser s a                      -> Parser s a
        Empt  ::                                    Parser s a
        Disj  :: Parser s a -> Parser s a        -> Parser s a
        Yuck  :: Parser s a                      -> Parser s a
        Enter :: String -> Parser s a            -> Parser s a

    -- | Parser process
    data Steps s a where
        Val     :: a -> Steps s r                                -> Steps s (a :< r)
        App     :: Steps s ((b -> a) :< (b :< r))                -> Steps s (a :< r)
        Done    ::                                                  Steps s ()
        Shift   :: Steps s a                                     -> Steps s a
        Sh'     :: Steps s a                                     -> Steps s a
        Sus     :: Steps s a -> (s -> Steps s a)                 -> Steps s a
        Best    :: Ordering -> Profile -> Steps s a -> Steps s a -> Steps s a
        Dislike :: Steps s a                                     -> Steps s a
        Log     :: String -> Steps s a                           -> Steps s a
        Fail    ::                                                  Steps s a

    -- profile !! s = number of Dislikes found to do s Shifts
    data ProfileF a = PSusp | PFail | PRes a | !a :> ProfileF a
        deriving (Int -> ProfileF a -> ShowS
    [ProfileF a] -> ShowS
    ProfileF a -> String
    (Int -> ProfileF a -> ShowS)
    -> (ProfileF a -> String)
    -> ([ProfileF a] -> ShowS)
    -> Show (ProfileF a)
    forall a. Show a => Int -> ProfileF a -> ShowS
    forall a. Show a => [ProfileF a] -> ShowS
    forall a. Show a => ProfileF a -> String
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: forall a. Show a => Int -> ProfileF a -> ShowS
    showsPrec :: Int -> ProfileF a -> ShowS
    $cshow :: forall a. Show a => ProfileF a -> String
    show :: ProfileF a -> String
    $cshowList :: forall a. Show a => [ProfileF a] -> ShowS
    showList :: [ProfileF a] -> ShowS
    Show, (forall a b. (a -> b) -> ProfileF a -> ProfileF b)
    -> (forall a b. a -> ProfileF b -> ProfileF a) -> Functor ProfileF
    forall a b. a -> ProfileF b -> ProfileF a
    forall a b. (a -> b) -> ProfileF a -> ProfileF b
    forall (f :: * -> *).
    (forall a b. (a -> b) -> f a -> f b)
    -> (forall a b. a -> f b -> f a) -> Functor f
    $cfmap :: forall a b. (a -> b) -> ProfileF a -> ProfileF b
    fmap :: forall a b. (a -> b) -> ProfileF a -> ProfileF b
    $c<$ :: forall a b. a -> ProfileF b -> ProfileF a
    <$ :: forall a b. a -> ProfileF b -> ProfileF a
    Functor)

    type Profile = ProfileF Int

    -- Map lookahead to maximum dislike difference we accept. When looking much further,
    -- we are more prone to discard smaller differences. It's essential that this drops below 0 when
    -- its argument increases, so that we can discard things with dislikes using only
    -- finite lookahead.
    dislikeThreshold :: Int -> Int
    dislikeThreshold :: Int -> Int
    dislikeThreshold Int
    n
        | Int
    n Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    5 = Int
    0
        | Bool
    otherwise = -Int
    1 -- we looked 5 tokens ahead, and still have no clue who is the best. Pick at random.

    -- | Compute the combination of two profiles, as well as which one is the best.
    better :: Int -> Profile -> Profile -> (Ordering, Profile)
    better :: Int -> Profile -> Profile -> (Ordering, Profile)
    better Int
    _ Profile
    PFail Profile
    p = (Ordering
    GT, Profile
    p) -- avoid failure
    better Int
    _ Profile
    p Profile
    PFail = (Ordering
    LT, Profile
    p)
    better Int
    _ Profile
    PSusp Profile
    _ = (Ordering
    EQ, Profile
    forall a. ProfileF a
    PSusp) -- could not decide before suspension => leave undecided.
    better Int
    _ Profile
    _ Profile
    PSusp = (Ordering
    EQ, Profile
    forall a. ProfileF a
    PSusp)
    better Int
    _ (PRes Int
    x) (PRes Int
    y) = if Int
    x Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    y then (Ordering
    LT, Int -> Profile
    forall a. a -> ProfileF a
    PRes Int
    x) else (Ordering
    GT, Int -> Profile
    forall a. a -> ProfileF a
    PRes Int
    y)  -- two results, just pick the best.
    better Int
    lk xs :: Profile
    xs@(PRes Int
    x) (Int
    y:>Profile
    ys) = if Int
    x Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0 Bool -> Bool -> Bool
    || Int
    yInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    x Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int -> Int
    dislikeThreshold Int
    lk then (Ordering
    LT, Profile
    xs) else Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    min Int
    x Int
    y Int -> (Ordering, Profile) -> (Ordering, Profile)
    forall t. Int -> (t, Profile) -> (t, Profile)
    +> Int -> Profile -> Profile -> (Ordering, Profile)
    better (Int
    lkInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1) Profile
    xs Profile
    ys
    better Int
    lk (Int
    y:>Profile
    ys) xs :: Profile
    xs@(PRes Int
    x) = if Int
    x Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0 Bool -> Bool -> Bool
    || Int
    yInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    x Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int -> Int
    dislikeThreshold Int
    lk then (Ordering
    GT, Profile
    xs) else Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    min Int
    x Int
    y Int -> (Ordering, Profile) -> (Ordering, Profile)
    forall t. Int -> (t, Profile) -> (t, Profile)
    +> Int -> Profile -> Profile -> (Ordering, Profile)
    better (Int
    lkInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1) Profile
    ys Profile
    xs
    better Int
    lk (Int
    x:>Profile
    xs) (Int
    y:>Profile
    ys)
        | Int
    x Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0 Bool -> Bool -> Bool
    && Int
    y Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0 = (Ordering, Profile)
    recur -- never drop things with no error: this ensures to find a correct parse if it exists.
        | Int
    x Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    y Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    threshold = (Ordering
    GT, Int
    yInt -> Profile -> Profile
    forall a. a -> ProfileF a -> ProfileF a
    :>Profile
    ys)
        | Int
    y Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    x Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    threshold = (Ordering
    LT, Int
    xInt -> Profile -> Profile
    forall a. a -> ProfileF a -> ProfileF a
    :>Profile
    xs) -- if at any point something is too disliked, drop it.
        | Bool
    otherwise = (Ordering, Profile)
    recur
        where threshold :: Int
    threshold = Int -> Int
    dislikeThreshold Int
    lk
              recur :: (Ordering, Profile)
    recur = Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    min Int
    x Int
    y Int -> (Ordering, Profile) -> (Ordering, Profile)
    forall t. Int -> (t, Profile) -> (t, Profile)
    +> Int -> Profile -> Profile -> (Ordering, Profile)
    better (Int
    lk Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) Profile
    xs Profile
    ys

    (+>) :: Int -> (t, Profile) -> (t, Profile)
    Int
    x +> :: forall t. Int -> (t, Profile) -> (t, Profile)
    +> ~(t
    ordering, Profile
    xs) = (t
    ordering, Int
    x Int -> Profile -> Profile
    forall a. a -> ProfileF a -> ProfileF a
    :> Profile
    xs)

    data LogEntry = LLog String | LEmpty | LDislike | LShift
                    | LDone | LFail | LSusp | LS String
        deriving Int -> LogEntry -> ShowS
    [LogEntry] -> ShowS
    LogEntry -> String
    (Int -> LogEntry -> ShowS)
    -> (LogEntry -> String) -> ([LogEntry] -> ShowS) -> Show LogEntry
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> LogEntry -> ShowS
    showsPrec :: Int -> LogEntry -> ShowS
    $cshow :: LogEntry -> String
    show :: LogEntry -> String
    $cshowList :: [LogEntry] -> ShowS
    showList :: [LogEntry] -> ShowS
    Show

    rightLog :: Steps s r -> Tree LogEntry
    rightLog :: forall s r. Steps s r -> Tree LogEntry
    rightLog (Val a
    _ Steps s r
    p) = Steps s r -> Tree LogEntry
    forall s r. Steps s r -> Tree LogEntry
    rightLog Steps s r
    p
    rightLog (App Steps s ((b -> a) :< (b :< r))
    p) = Steps s ((b -> a) :< (b :< r)) -> Tree LogEntry
    forall s r. Steps s r -> Tree LogEntry
    rightLog Steps s ((b -> a) :< (b :< r))
    p
    rightLog (Shift Steps s r
    p) = LogEntry -> [Tree LogEntry] -> Tree LogEntry
    forall a. a -> [Tree a] -> Tree a
    Node LogEntry
    LShift [Steps s r -> Tree LogEntry
    forall s r. Steps s r -> Tree LogEntry
    rightLog Steps s r
    p]
    rightLog (Steps s r
    Done) = LogEntry -> [Tree LogEntry] -> Tree LogEntry
    forall a. a -> [Tree a] -> Tree a
    Node LogEntry
    LDone []
    rightLog (Steps s r
    Fail) = LogEntry -> [Tree LogEntry] -> Tree LogEntry
    forall a. a -> [Tree a] -> Tree a
    Node LogEntry
    LFail []
    rightLog (Dislike Steps s r
    p) = LogEntry -> [Tree LogEntry] -> Tree LogEntry
    forall a. a -> [Tree a] -> Tree a
    Node LogEntry
    LDislike [Steps s r -> Tree LogEntry
    forall s r. Steps s r -> Tree LogEntry
    rightLog Steps s r
    p]
    rightLog (Log String
    msg Steps s r
    p) = LogEntry -> [Tree LogEntry] -> Tree LogEntry
    forall a. a -> [Tree a] -> Tree a
    Node (String -> LogEntry
    LLog String
    msg) [Steps s r -> Tree LogEntry
    forall s r. Steps s r -> Tree LogEntry
    rightLog Steps s r
    p]
    rightLog (Sus Steps s r
    _ s -> Steps s r
    _) = LogEntry -> [Tree LogEntry] -> Tree LogEntry
    forall a. a -> [Tree a] -> Tree a
    Node LogEntry
    LSusp []
    rightLog (Best Ordering
    _ Profile
    _ Steps s r
    l Steps s r
    r) = LogEntry -> [Tree LogEntry] -> Tree LogEntry
    forall a. a -> [Tree a] -> Tree a
    Node LogEntry
    LEmpty (Steps s r -> Tree LogEntry
    forall s r. Steps s r -> Tree LogEntry
    rightLog Steps s r
    lTree LogEntry -> [Tree LogEntry] -> [Tree LogEntry]
    forall a. a -> [a] -> [a]
    :[Steps s r -> Tree LogEntry
    forall s r. Steps s r -> Tree LogEntry
    rightLog Steps s r
    r])
    rightLog (Sh' Steps s r
    _) = String -> Tree LogEntry
    forall a. HasCallStack => String -> a
    error String
    "Sh' should be hidden by Sus"

    profile :: Steps s r -> Profile
    profile :: forall s r. Steps s r -> Profile
    profile (Val a
    _ Steps s r
    p) = Steps s r -> Profile
    forall s r. Steps s r -> Profile
    profile Steps s r
    p
    profile (App Steps s ((b -> a) :< (b :< r))
    p) = Steps s ((b -> a) :< (b :< r)) -> Profile
    forall s r. Steps s r -> Profile
    profile Steps s ((b -> a) :< (b :< r))
    p
    profile (Shift Steps s r
    p) = Int
    0 Int -> Profile -> Profile
    forall a. a -> ProfileF a -> ProfileF a
    :> Steps s r -> Profile
    forall s r. Steps s r -> Profile
    profile Steps s r
    p
    profile (Steps s r
    Done) = Int -> Profile
    forall a. a -> ProfileF a
    PRes Int
    0 -- success with zero dislikes
    profile (Steps s r
    Fail) = Profile
    forall a. ProfileF a
    PFail
    profile (Dislike Steps s r
    p) = (Int -> Int) -> Profile -> Profile
    forall a b. (a -> b) -> ProfileF a -> ProfileF b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Int -> Int
    forall a. Enum a => a -> a
    succ (Steps s r -> Profile
    forall s r. Steps s r -> Profile
    profile Steps s r
    p)
    profile (Log String
    _ Steps s r
    p) = Steps s r -> Profile
    forall s r. Steps s r -> Profile
    profile Steps s r
    p
    profile (Sus Steps s r
    _ s -> Steps s r
    _) = Profile
    forall a. ProfileF a
    PSusp
    profile (Best Ordering
    _ Profile
    pr Steps s r
    _ Steps s r
    _) = Profile
    pr
    profile (Sh' Steps s r
    _) = String -> Profile
    forall a. HasCallStack => String -> a
    error String
    "Sh' should be hidden by Sus"

    instance Show (Steps s r) where
        show :: Steps s r -> String
    show (Val a
    _ Steps s r
    p) = Char
    'v' Char -> ShowS
    forall a. a -> [a] -> [a]
    : Steps s r -> String
    forall a. Show a => a -> String
    show Steps s r
    p
        show (App Steps s ((b -> a) :< (b :< r))
    p) = Char
    '*' Char -> ShowS
    forall a. a -> [a] -> [a]
    : Steps s ((b -> a) :< (b :< r)) -> String
    forall a. Show a => a -> String
    show Steps s ((b -> a) :< (b :< r))
    p
        show (Steps s r
    Done) = String
    "1"
        show (Shift Steps s r
    p) = Char
    '>' Char -> ShowS
    forall a. a -> [a] -> [a]
    : Steps s r -> String
    forall a. Show a => a -> String
    show Steps s r
    p
        show (Sh' Steps s r
    p) = Char
    '\'' Char -> ShowS
    forall a. a -> [a] -> [a]
    : Steps s r -> String
    forall a. Show a => a -> String
    show Steps s r
    p
        show (Dislike Steps s r
    p) = Char
    '?' Char -> ShowS
    forall a. a -> [a] -> [a]
    : Steps s r -> String
    forall a. Show a => a -> String
    show Steps s r
    p
        show (Log String
    msg Steps s r
    p) = String
    "[" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    msg String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "]"  String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Steps s r -> String
    forall a. Show a => a -> String
    show Steps s r
    p
        show (Steps s r
    Fail) = String
    "0"
        show (Sus Steps s r
    _ s -> Steps s r
    _) = String
    "..."
        show (Best Ordering
    _ Profile
    _ Steps s r
    p Steps s r
    q) = String
    "(" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Steps s r -> String
    forall a. Show a => a -> String
    show Steps s r
    p String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    ")" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Steps s r -> String
    forall a. Show a => a -> String
    show Steps s r
    q

    countWidth :: Zip s r -> Int
    countWidth :: forall s r. Zip s r -> Int
    countWidth (Zip [String]
    _ RPolish mid r
    _ Steps s mid
    r) = Steps s mid -> Int
    forall s r. Steps s r -> Int
    countWidth' Steps s mid
    r
      where countWidth' :: Steps s r -> Int
            countWidth' :: forall s r. Steps s r -> Int
    countWidth' Steps s r
    r' = case Steps s r
    r' of
                (Best Ordering
    _ Profile
    _ Steps s r
    p Steps s r
    q) ->  Steps s r -> Int
    forall s r. Steps s r -> Int
    countWidth' Steps s r
    p Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Steps s r -> Int
    forall s r. Steps s r -> Int
    countWidth' Steps s r
    q
                (Val a
    _ Steps s r
    p) -> Steps s r -> Int
    forall s r. Steps s r -> Int
    countWidth' Steps s r
    p
                (App Steps s ((b -> a) :< (b :< r))
    p) -> Steps s ((b -> a) :< (b :< r)) -> Int
    forall s r. Steps s r -> Int
    countWidth' Steps s ((b -> a) :< (b :< r))
    p
                (Steps s r
    Done) -> Int
    1
                (Shift Steps s r
    p) -> Steps s r -> Int
    forall s r. Steps s r -> Int
    countWidth' Steps s r
    p
                (Sh' Steps s r
    p) -> Steps s r -> Int
    forall s r. Steps s r -> Int
    countWidth' Steps s r
    p
                (Dislike Steps s r
    p) -> Steps s r -> Int
    forall s r. Steps s r -> Int
    countWidth' Steps s r
    p
                (Log String
    _ Steps s r
    p) -> Steps s r -> Int
    forall s r. Steps s r -> Int
    countWidth' Steps s r
    p
                (Steps s r
    Fail) -> Int
    1
                (Sus Steps s r
    _ s -> Steps s r
    _) -> Int
    1

    instance Show (RPolish i o) where
        show :: RPolish i o -> String
    show (RPush a
    _ RPolish (a :< i) o
    p) = RPolish (a :< i) o -> String
    forall a. Show a => a -> String
    show RPolish (a :< i) o
    p String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "^"
        show (RApp RPolish (b :< rest) o
    p) = RPolish (b :< rest) o -> String
    forall a. Show a => a -> String
    show RPolish (b :< rest) o
    p String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "@"
        show (RPolish i o
    RStop) = String
    "!"

    apply :: forall t t1 a. ((t -> a) :< (t :< t1)) -> a :< t1
    apply :: forall t t1 a. ((t -> a) :< (t :< t1)) -> a :< t1
    apply ~(t -> a
    f:< ~(t
    a:<t1
    r)) = t -> a
    f t
    a a -> t1 -> a :< t1
    forall a b. a -> b -> a :< b
    :< t1
    r

    -- | Right-eval a fully defined process (ie. one that has no Sus)
    evalR' :: Steps s r -> (r, [String])
    evalR' :: forall s r. Steps s r -> (r, [String])
    evalR' Steps s r
    Done = ((), [])
    evalR' (Val a
    a Steps s r
    r) = (r -> a :< r) -> (r, [String]) -> (a :< r, [String])
    forall b c d. (b -> c) -> (b, d) -> (c, d)
    forall (a :: * -> * -> *) b c d.
    Arrow a =>
    a b c -> a (b, d) (c, d)
    first (a
    a a -> r -> a :< r
    forall a b. a -> b -> a :< b
    :<) (Steps s r -> (r, [String])
    forall s r. Steps s r -> (r, [String])
    evalR' Steps s r
    r)
    evalR' (App Steps s ((b -> a) :< (b :< r))
    s) = (((b -> a) :< (b :< r)) -> a :< r)
    -> ((b -> a) :< (b :< r), [String]) -> (a :< r, [String])
    forall b c d. (b -> c) -> (b, d) -> (c, d)
    forall (a :: * -> * -> *) b c d.
    Arrow a =>
    a b c -> a (b, d) (c, d)
    first ((b -> a) :< (b :< r)) -> a :< r
    forall t t1 a. ((t -> a) :< (t :< t1)) -> a :< t1
    apply (Steps s ((b -> a) :< (b :< r)) -> ((b -> a) :< (b :< r), [String])
    forall s r. Steps s r -> (r, [String])
    evalR' Steps s ((b -> a) :< (b :< r))
    s)
    evalR' (Shift Steps s r
    v) = Steps s r -> (r, [String])
    forall s r. Steps s r -> (r, [String])
    evalR' Steps s r
    v
    evalR' (Dislike Steps s r
    v) = Steps s r -> (r, [String])
    forall s r. Steps s r -> (r, [String])
    evalR' Steps s r
    v
    evalR' (Log String
    err Steps s r
    v) = ([String] -> [String]) -> (r, [String]) -> (r, [String])
    forall b c d. (b -> c) -> (d, b) -> (d, c)
    forall (a :: * -> * -> *) b c d.
    Arrow a =>
    a b c -> a (d, b) (d, c)
    second (String
    errString -> [String] -> [String]
    forall a. a -> [a] -> [a]
    :) (Steps s r -> (r, [String])
    forall s r. Steps s r -> (r, [String])
    evalR' Steps s r
    v)
    evalR' (Steps s r
    Fail) = String -> (r, [String])
    forall a. HasCallStack => String -> a
    error String
    "evalR: No parse!"
    evalR' (Sus Steps s r
    _ s -> Steps s r
    _) = String -> (r, [String])
    forall a. HasCallStack => String -> a
    error String
    "evalR: Not fully evaluated!"
    evalR' (Sh' Steps s r
    _) = String -> (r, [String])
    forall a. HasCallStack => String -> a
    error String
    "evalR: Sh' should be hidden by Sus"
    evalR' (Best Ordering
    choice Profile
    _ Steps s r
    p Steps s r
    q) = case Ordering
    choice of
        Ordering
    LT -> Steps s r -> (r, [String])
    forall s r. Steps s r -> (r, [String])
    evalR' Steps s r
    p
        Ordering
    GT -> Steps s r -> (r, [String])
    forall s r. Steps s r -> (r, [String])
    evalR' Steps s r
    q
        Ordering
    EQ -> String -> (r, [String])
    forall a. HasCallStack => String -> a
    error (String -> (r, [String])) -> String -> (r, [String])
    forall a b. (a -> b) -> a -> b
    $ String
    "evalR: Ambiguous parse: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Steps s r -> String
    forall a. Show a => a -> String
    show Steps s r
    p String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    " ~~~ " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Steps s r -> String
    forall a. Show a => a -> String
    show Steps s r
    q

    instance Functor (Parser s) where
        fmap :: forall a b. (a -> b) -> Parser s a -> Parser s b
    fmap a -> b
    f = ((a -> b) -> Parser s (a -> b)
    forall a. a -> Parser s a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure a -> b
    f Parser s (a -> b) -> Parser s a -> Parser s b
    forall a b. Parser s (a -> b) -> Parser s a -> Parser s b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*>)

    instance Applicative (Parser s) where
        <*> :: forall a b. Parser s (a -> b) -> Parser s a -> Parser s b
    (<*>) = Parser s (a -> b) -> Parser s a -> Parser s b
    forall s a b. Parser s (a -> b) -> Parser s a -> Parser s b
    Appl
        pure :: forall a. a -> Parser s a
    pure = a -> Parser s a
    forall a s. a -> Parser s a
    Pure

    instance Alternative (Parser s) where
        <|> :: forall a. Parser s a -> Parser s a -> Parser s a
    (<|>) = Parser s a -> Parser s a -> Parser s a
    forall s a. Parser s a -> Parser s a -> Parser s a
    Disj
        empty :: forall a. Parser s a
    empty = Parser s a
    forall s a. Parser s a
    Empt

    instance Monad (Parser s) where
        >>= :: forall a b. Parser s a -> (a -> Parser s b) -> Parser s b
    (>>=) = Parser s a -> (a -> Parser s b) -> Parser s b
    forall s a b. Parser s a -> (a -> Parser s b) -> Parser s b
    Bind
        return :: forall a. a -> Parser s a
    return = a -> Parser s a
    forall a. a -> Parser s a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure
    #if (!MIN_VERSION_base(4,13,0))
        fail _message = Empt
    #endif

    instance Fail.MonadFail (Parser s) where
        fail :: forall a. String -> Parser s a
    fail String
    _message = Parser s a
    forall s a. Parser s a
    Empt

    toQ :: Parser s a -> forall h r. ((h,a) -> Steps s r)  -> h -> Steps s r
    toQ :: forall s a.
    Parser s a -> forall h r. ((h, a) -> Steps s r) -> h -> Steps s r
    toQ (Look Parser s a
    a s -> Parser s a
    f) = \(h, a) -> Steps s r
    k h
    h -> Steps s r -> (s -> Steps s r) -> Steps s r
    forall s a. Steps s a -> (s -> Steps s a) -> Steps s a
    Sus (Parser s a -> forall h r. ((h, a) -> Steps s r) -> h -> Steps s r
    forall s a.
    Parser s a -> forall h r. ((h, a) -> Steps s r) -> h -> Steps s r
    toQ Parser s a
    a (h, a) -> Steps s r
    k h
    h) (\s
    s -> Parser s a -> forall h r. ((h, a) -> Steps s r) -> h -> Steps s r
    forall s a.
    Parser s a -> forall h r. ((h, a) -> Steps s r) -> h -> Steps s r
    toQ (s -> Parser s a
    f s
    s) (h, a) -> Steps s r
    k h
    h)
    toQ (Parser s (b -> a)
    p `Appl` Parser s b
    q) = \(h, a) -> Steps s r
    k -> Parser s (b -> a)
    -> forall h r. ((h, b -> a) -> Steps s r) -> h -> Steps s r
    forall s a.
    Parser s a -> forall h r. ((h, a) -> Steps s r) -> h -> Steps s r
    toQ Parser s (b -> a)
    p (((h, b -> a) -> Steps s r) -> h -> Steps s r)
    -> ((h, b -> a) -> Steps s r) -> h -> Steps s r
    forall a b. (a -> b) -> a -> b
    $ Parser s b -> forall h r. ((h, b) -> Steps s r) -> h -> Steps s r
    forall s a.
    Parser s a -> forall h r. ((h, a) -> Steps s r) -> h -> Steps s r
    toQ Parser s b
    q ((((h, b -> a), b) -> Steps s r) -> (h, b -> a) -> Steps s r)
    -> (((h, b -> a), b) -> Steps s r) -> (h, b -> a) -> Steps s r
    forall a b. (a -> b) -> a -> b
    $ \((h
    h, b -> a
    b2a), b
    b) -> (h, a) -> Steps s r
    k (h
    h, b -> a
    b2a b
    b)
    toQ (Pure a
    a)     = \(h, a) -> Steps s r
    k h
    h -> (h, a) -> Steps s r
    k (h
    h, a
    a)
    toQ (Disj Parser s a
    p Parser s a
    q)   = \(h, a) -> Steps s r
    k h
    h -> Steps s r -> Steps s r -> Steps s r
    forall s a. Steps s a -> Steps s a -> Steps s a
    iBest (Parser s a -> forall h r. ((h, a) -> Steps s r) -> h -> Steps s r
    forall s a.
    Parser s a -> forall h r. ((h, a) -> Steps s r) -> h -> Steps s r
    toQ Parser s a
    p (h, a) -> Steps s r
    k h
    h) (Parser s a -> forall h r. ((h, a) -> Steps s r) -> h -> Steps s r
    forall s a.
    Parser s a -> forall h r. ((h, a) -> Steps s r) -> h -> Steps s r
    toQ Parser s a
    q (h, a) -> Steps s r
    k h
    h)
    toQ (Bind Parser s a
    p a -> Parser s a
    a2q) = \(h, a) -> Steps s r
    k -> Parser s a -> forall h r. ((h, a) -> Steps s r) -> h -> Steps s r
    forall s a.
    Parser s a -> forall h r. ((h, a) -> Steps s r) -> h -> Steps s r
    toQ Parser s a
    p (\(h
    h,a
    a) -> Parser s a -> forall h r. ((h, a) -> Steps s r) -> h -> Steps s r
    forall s a.
    Parser s a -> forall h r. ((h, a) -> Steps s r) -> h -> Steps s r
    toQ (a -> Parser s a
    a2q a
    a) (h, a) -> Steps s r
    k h
    h)
    toQ Parser s a
    Empt = \(h, a) -> Steps s r
    _k h
    _h -> Steps s r
    forall s a. Steps s a
    Fail
    toQ (Yuck Parser s a
    p) = \(h, a) -> Steps s r
    k h
    h -> Steps s r -> Steps s r
    forall s a. Steps s a -> Steps s a
    Dislike (Steps s r -> Steps s r) -> Steps s r -> Steps s r
    forall a b. (a -> b) -> a -> b
    $ Parser s a -> forall h r. ((h, a) -> Steps s r) -> h -> Steps s r
    forall s a.
    Parser s a -> forall h r. ((h, a) -> Steps s r) -> h -> Steps s r
    toQ Parser s a
    p (h, a) -> Steps s r
    k h
    h
    toQ (Enter String
    err Parser s a
    p) = \(h, a) -> Steps s r
    k h
    h -> String -> Steps s r -> Steps s r
    forall s a. String -> Steps s a -> Steps s a
    Log String
    err (Steps s r -> Steps s r) -> Steps s r -> Steps s r
    forall a b. (a -> b) -> a -> b
    $ Parser s a -> forall h r. ((h, a) -> Steps s r) -> h -> Steps s r
    forall s a.
    Parser s a -> forall h r. ((h, a) -> Steps s r) -> h -> Steps s r
    toQ Parser s a
    p (h, a) -> Steps s r
    k h
    h
    toQ (Shif Parser s a
    p) = \(h, a) -> Steps s r
    k h
    h -> Steps s r -> Steps s r
    forall s a. Steps s a -> Steps s a
    Sh' (Steps s r -> Steps s r) -> Steps s r -> Steps s r
    forall a b. (a -> b) -> a -> b
    $ Parser s a -> forall h r. ((h, a) -> Steps s r) -> h -> Steps s r
    forall s a.
    Parser s a -> forall h r. ((h, a) -> Steps s r) -> h -> Steps s r
    toQ Parser s a
    p (h, a) -> Steps s r
    k h
    h

    toP :: Parser s a -> forall r. Steps s r -> Steps s (a :< r)
    toP :: forall s a. Parser s a -> forall r. Steps s r -> Steps s (a :< r)
    toP (Look Parser s a
    a s -> Parser s a
    f) = {-# SCC "toP_Look" #-} \Steps s r
    fut -> Steps s (a :< r) -> (s -> Steps s (a :< r)) -> Steps s (a :< r)
    forall s a. Steps s a -> (s -> Steps s a) -> Steps s a
    Sus (Parser s a -> forall r. Steps s r -> Steps s (a :< r)
    forall s a. Parser s a -> forall r. Steps s r -> Steps s (a :< r)
    toP Parser s a
    a Steps s r
    fut) (\s
    s -> Parser s a -> forall r. Steps s r -> Steps s (a :< r)
    forall s a. Parser s a -> forall r. Steps s r -> Steps s (a :< r)
    toP (s -> Parser s a
    f s
    s) Steps s r
    fut)
    toP (Appl Parser s (b -> a)
    f Parser s b
    x) = {-# SCC "toP_Appl" #-} Steps s ((b -> a) :< (b :< r)) -> Steps s (a :< r)
    forall s mid rest a.
    Steps s ((mid -> rest) :< (mid :< a)) -> Steps s (rest :< a)
    App (Steps s ((b -> a) :< (b :< r)) -> Steps s (a :< r))
    -> (Steps s r -> Steps s ((b -> a) :< (b :< r)))
    -> Steps s r
    -> Steps s (a :< r)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Parser s (b -> a) -> forall r. Steps s r -> Steps s ((b -> a) :< r)
    forall s a. Parser s a -> forall r. Steps s r -> Steps s (a :< r)
    toP Parser s (b -> a)
    f (Steps s (b :< r) -> Steps s ((b -> a) :< (b :< r)))
    -> (Steps s r -> Steps s (b :< r))
    -> Steps s r
    -> Steps s ((b -> a) :< (b :< r))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Parser s b -> forall r. Steps s r -> Steps s (b :< r)
    forall s a. Parser s a -> forall r. Steps s r -> Steps s (a :< r)
    toP Parser s b
    x
    toP (Pure a
    x)   = {-# SCC "toP_Pure" #-} a -> Steps s r -> Steps s (a :< r)
    forall mid s rest. mid -> Steps s rest -> Steps s (mid :< rest)
    Val a
    x
    toP Parser s a
    Empt = {-# SCC "toP_Empt" #-} Steps s (a :< r) -> Steps s r -> Steps s (a :< r)
    forall a b. a -> b -> a
    const Steps s (a :< r)
    forall s a. Steps s a
    Fail
    toP (Disj Parser s a
    a Parser s a
    b)  = {-# SCC "toP_Disj" #-} \Steps s r
    fut -> Steps s (a :< r) -> Steps s (a :< r) -> Steps s (a :< r)
    forall s a. Steps s a -> Steps s a -> Steps s a
    iBest (Parser s a -> forall r. Steps s r -> Steps s (a :< r)
    forall s a. Parser s a -> forall r. Steps s r -> Steps s (a :< r)
    toP Parser s a
    a Steps s r
    fut) (Parser s a -> forall r. Steps s r -> Steps s (a :< r)
    forall s a. Parser s a -> forall r. Steps s r -> Steps s (a :< r)
    toP Parser s a
    b Steps s r
    fut)
    toP (Bind Parser s a
    p a -> Parser s a
    a2q) = {-# SCC "toP_Bind" #-} \Steps s r
    fut -> Parser s a -> forall h r. ((h, a) -> Steps s r) -> h -> Steps s r
    forall s a.
    Parser s a -> forall h r. ((h, a) -> Steps s r) -> h -> Steps s r
    toQ Parser s a
    p (\(()
    _,a
    a) -> Parser s a -> forall r. Steps s r -> Steps s (a :< r)
    forall s a. Parser s a -> forall r. Steps s r -> Steps s (a :< r)
    toP (a -> Parser s a
    a2q a
    a) Steps s r
    fut) ()
    toP (Yuck Parser s a
    p) = {-# SCC "toP_Yuck" #-} Steps s (a :< r) -> Steps s (a :< r)
    forall s a. Steps s a -> Steps s a
    Dislike (Steps s (a :< r) -> Steps s (a :< r))
    -> (Steps s r -> Steps s (a :< r)) -> Steps s r -> Steps s (a :< r)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Parser s a -> forall r. Steps s r -> Steps s (a :< r)
    forall s a. Parser s a -> forall r. Steps s r -> Steps s (a :< r)
    toP Parser s a
    p
    toP (Enter String
    err Parser s a
    p) = {-# SCC "toP_Enter" #-} String -> Steps s (a :< r) -> Steps s (a :< r)
    forall s a. String -> Steps s a -> Steps s a
    Log String
    err (Steps s (a :< r) -> Steps s (a :< r))
    -> (Steps s r -> Steps s (a :< r)) -> Steps s r -> Steps s (a :< r)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Parser s a -> forall r. Steps s r -> Steps s (a :< r)
    forall s a. Parser s a -> forall r. Steps s r -> Steps s (a :< r)
    toP Parser s a
    p
    toP (Shif Parser s a
    p) = {-# SCC "toP_Shif" #-} Steps s (a :< r) -> Steps s (a :< r)
    forall s a. Steps s a -> Steps s a
    Sh' (Steps s (a :< r) -> Steps s (a :< r))
    -> (Steps s r -> Steps s (a :< r)) -> Steps s r -> Steps s (a :< r)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Parser s a -> forall r. Steps s r -> Steps s (a :< r)
    forall s a. Parser s a -> forall r. Steps s r -> Steps s (a :< r)
    toP Parser s a
    p

    -- | Intelligent, caching best.
    iBest :: Steps s a -> Steps s a -> Steps s a
    iBest :: forall s a. Steps s a -> Steps s a -> Steps s a
    iBest Steps s a
    p Steps s a
    q = let ~(Ordering
    choice, Profile
    pr) = Int -> Profile -> Profile -> (Ordering, Profile)
    better Int
    0 (Steps s a -> Profile
    forall s r. Steps s r -> Profile
    profile Steps s a
    p) (Steps s a -> Profile
    forall s r. Steps s r -> Profile
    profile Steps s a
    q) in Ordering -> Profile -> Steps s a -> Steps s a -> Steps s a
    forall s a.
    Ordering -> Profile -> Steps s a -> Steps s a -> Steps s a
    Best Ordering
    choice Profile
    pr Steps s a
    p Steps s a
    q

    symbol :: forall s. (s -> Bool) -> Parser s s
    symbol :: forall s. (s -> Bool) -> Parser s s
    symbol s -> Bool
    f = Parser s s -> (s -> Parser s s) -> Parser s s
    forall s a. Parser s a -> (s -> Parser s a) -> Parser s a
    Look Parser s s
    forall a. Parser s a
    forall (f :: * -> *) a. Alternative f => f a
    empty ((s -> Parser s s) -> Parser s s)
    -> (s -> Parser s s) -> Parser s s
    forall a b. (a -> b) -> a -> b
    $ \s
    s -> if s -> Bool
    f s
    s then Parser s s -> Parser s s
    forall s a. Parser s a -> Parser s a
    Shif (Parser s s -> Parser s s) -> Parser s s -> Parser s s
    forall a b. (a -> b) -> a -> b
    $ s -> Parser s s
    forall a. a -> Parser s a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure s
    s else Parser s s
    forall a. Parser s a
    forall (f :: * -> *) a. Alternative f => f a
    empty

    eof :: forall s. Parser s ()
    eof :: forall s. Parser s ()
    eof = Parser s () -> (s -> Parser s ()) -> Parser s ()
    forall s a. Parser s a -> (s -> Parser s a) -> Parser s a
    Look (() -> Parser s ()
    forall a. a -> Parser s a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()) (Parser s () -> s -> Parser s ()
    forall a b. a -> b -> a
    const Parser s ()
    forall a. Parser s a
    forall (f :: * -> *) a. Alternative f => f a
    empty)

    -- | Push a chunk of symbols or eof in the process. This forces some suspensions.
    feed :: Maybe [s] -> Steps s r -> Steps s r
    feed :: forall s r. Maybe [s] -> Steps s r -> Steps s r
    feed (Just []) Steps s r
    p = Steps s r
    p  -- nothing more left to feed
    feed Maybe [s]
    ss Steps s r
    p = case Steps s r
    p of
                      (Sus Steps s r
    nil s -> Steps s r
    cons) -> case Maybe [s]
    ss of
                          Just [] -> Steps s r
    p -- no more info, stop feeding
                          Maybe [s]
    Nothing -> Maybe [s] -> Steps s r -> Steps s r
    forall s r. Maybe [s] -> Steps s r -> Steps s r
    feed Maybe [s]
    forall a. Maybe a
    Nothing Steps s r
    nil -- finish
                          Just (s
    s:[s]
    _) -> Maybe [s] -> Steps s r -> Steps s r
    forall s r. Maybe [s] -> Steps s r -> Steps s r
    feed Maybe [s]
    ss (s -> Steps s r
    cons s
    s)
                      (Shift Steps s r
    p') -> Steps s r -> Steps s r
    forall s a. Steps s a -> Steps s a
    Shift (Maybe [s] -> Steps s r -> Steps s r
    forall s r. Maybe [s] -> Steps s r -> Steps s r
    feed Maybe [s]
    ss Steps s r
    p')
                      (Sh' Steps s r
    p')   -> Steps s r -> Steps s r
    forall s a. Steps s a -> Steps s a
    Shift (Maybe [s] -> Steps s r -> Steps s r
    forall s r. Maybe [s] -> Steps s r -> Steps s r
    feed (([s] -> [s]) -> Maybe [s] -> Maybe [s]
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Int -> [s] -> [s]
    forall a. Int -> [a] -> [a]
    drop Int
    1) Maybe [s]
    ss) Steps s r
    p')
                      (Dislike Steps s r
    p') -> Steps s r -> Steps s r
    forall s a. Steps s a -> Steps s a
    Dislike (Maybe [s] -> Steps s r -> Steps s r
    forall s r. Maybe [s] -> Steps s r -> Steps s r
    feed Maybe [s]
    ss Steps s r
    p')
                      (Log String
    err Steps s r
    p') -> String -> Steps s r -> Steps s r
    forall s a. String -> Steps s a -> Steps s a
    Log String
    err (Maybe [s] -> Steps s r -> Steps s r
    forall s r. Maybe [s] -> Steps s r -> Steps s r
    feed Maybe [s]
    ss Steps s r
    p')
                      (Val a
    x Steps s r
    p') -> a -> Steps s r -> Steps s (a :< r)
    forall mid s rest. mid -> Steps s rest -> Steps s (mid :< rest)
    Val a
    x (Maybe [s] -> Steps s r -> Steps s r
    forall s r. Maybe [s] -> Steps s r -> Steps s r
    feed Maybe [s]
    ss Steps s r
    p')
                      (App Steps s ((b -> a) :< (b :< r))
    p') -> Steps s ((b -> a) :< (b :< r)) -> Steps s (a :< r)
    forall s mid rest a.
    Steps s ((mid -> rest) :< (mid :< a)) -> Steps s (rest :< a)
    App (Maybe [s]
    -> Steps s ((b -> a) :< (b :< r)) -> Steps s ((b -> a) :< (b :< r))
    forall s r. Maybe [s] -> Steps s r -> Steps s r
    feed Maybe [s]
    ss Steps s ((b -> a) :< (b :< r))
    p')
                      Steps s r
    Done -> Steps s r
    Steps s ()
    forall s. Steps s ()
    Done
                      Steps s r
    Fail -> Steps s r
    forall s a. Steps s a
    Fail
                      Best Ordering
    _ Profile
    _ Steps s r
    p' Steps s r
    q' -> Steps s r -> Steps s r -> Steps s r
    forall s a. Steps s a -> Steps s a -> Steps s a
    iBest (Maybe [s] -> Steps s r -> Steps s r
    forall s r. Maybe [s] -> Steps s r -> Steps s r
    feed Maybe [s]
    ss Steps s r
    p') (Maybe [s] -> Steps s r -> Steps s r
    forall s r. Maybe [s] -> Steps s r -> Steps s r
    feed Maybe [s]
    ss Steps s r
    q')
                      -- TODO: it would be nice to be able to reuse the profile here.

    feedZ :: Maybe [s] -> Zip s r -> Zip s r
    feedZ :: forall s r. Maybe [s] -> Zip s r -> Zip s r
    feedZ Maybe [s]
    x = (forall r. Steps s r -> Steps s r) -> Zip s r -> Zip s r
    forall s a.
    (forall r. Steps s r -> Steps s r) -> Zip s a -> Zip s a
    onRight (Maybe [s] -> Steps s r -> Steps s r
    forall s r. Maybe [s] -> Steps s r -> Steps s r
    feed Maybe [s]
    x)

    -- Move the zipper to right, and simplify if something is pushed in
    -- the left part.

    evalL :: forall s output. Zip s output -> Zip s output
    evalL :: forall s output. Zip s output -> Zip s output
    evalL (Zip [String]
    errs0 RPolish mid output
    l0 Steps s mid
    r0) = [String] -> RPolish mid output -> Steps s mid -> Zip s output
    forall mid.
    [String] -> RPolish mid output -> Steps s mid -> Zip s output
    help [String]
    errs0 RPolish mid output
    l0 Steps s mid
    r0
      where
          help :: [String] -> RPolish mid output -> Steps s mid -> Zip s output
          help :: forall mid.
    [String] -> RPolish mid output -> Steps s mid -> Zip s output
    help [String]
    errs RPolish mid output
    l Steps s mid
    rhs = case Steps s mid
    rhs of
              (Val a
    a Steps s r
    r) -> [String] -> RPolish r output -> Steps s r -> Zip s output
    forall mid.
    [String] -> RPolish mid output -> Steps s mid -> Zip s output
    help [String]
    errs (RPolish r output -> RPolish r output
    forall s output. RPolish s output -> RPolish s output
    simplify (a -> RPolish (a :< r) output -> RPolish r output
    forall mid rest output.
    mid -> RPolish (mid :< rest) output -> RPolish rest output
    RPush a
    a RPolish mid output
    RPolish (a :< r) output
    l)) Steps s r
    r
              (App Steps s ((b -> a) :< (b :< r))
    r)  -> [String]
    -> RPolish ((b -> a) :< (b :< r)) output
    -> Steps s ((b -> a) :< (b :< r))
    -> Zip s output
    forall mid.
    [String] -> RPolish mid output -> Steps s mid -> Zip s output
    help [String]
    errs (RPolish (a :< r) output -> RPolish ((b -> a) :< (b :< r)) output
    forall mid rest output a.
    RPolish (mid :< rest) output
    -> RPolish ((a -> mid) :< (a :< rest)) output
    RApp RPolish mid output
    RPolish (a :< r) output
    l) Steps s ((b -> a) :< (b :< r))
    r
              (Shift Steps s mid
    p) -> [String] -> RPolish mid output -> Steps s mid -> Zip s output
    forall mid.
    [String] -> RPolish mid output -> Steps s mid -> Zip s output
    help [String]
    errs RPolish mid output
    l Steps s mid
    p
              (Log String
    err Steps s mid
    p) -> [String] -> RPolish mid output -> Steps s mid -> Zip s output
    forall mid.
    [String] -> RPolish mid output -> Steps s mid -> Zip s output
    help (String
    errString -> [String] -> [String]
    forall a. a -> [a] -> [a]
    :[String]
    errs) RPolish mid output
    l Steps s mid
    p
              (Dislike Steps s mid
    p) -> [String] -> RPolish mid output -> Steps s mid -> Zip s output
    forall mid.
    [String] -> RPolish mid output -> Steps s mid -> Zip s output
    help [String]
    errs RPolish mid output
    l Steps s mid
    p
              (Best Ordering
    choice Profile
    _ Steps s mid
    p Steps s mid
    q) -> case Ordering
    choice of
                  Ordering
    LT -> [String] -> RPolish mid output -> Steps s mid -> Zip s output
    forall mid.
    [String] -> RPolish mid output -> Steps s mid -> Zip s output
    help [String]
    errs RPolish mid output
    l Steps s mid
    p
                  Ordering
    GT -> [String] -> RPolish mid output -> Steps s mid -> Zip s output
    forall mid.
    [String] -> RPolish mid output -> Steps s mid -> Zip s output
    help [String]
    errs RPolish mid output
    l Steps s mid
    q
                  Ordering
    EQ -> [String] -> RPolish mid output -> Steps s mid -> Zip s output
    forall mid.
    [String] -> RPolish mid output -> Steps s mid -> Zip s output
    reZip [String]
    errs RPolish mid output
    l Steps s mid
    rhs -- don't know where to go: don't speculate on evaluating either branch.
              Steps s mid
    _ -> [String] -> RPolish mid output -> Steps s mid -> Zip s output
    forall mid.
    [String] -> RPolish mid output -> Steps s mid -> Zip s output
    reZip [String]
    errs RPolish mid output
    l Steps s mid
    rhs
          reZip :: [String] -> RPolish mid output -> Steps s mid -> Zip s output
          reZip :: forall mid.
    [String] -> RPolish mid output -> Steps s mid -> Zip s output
    reZip [String]
    errs RPolish mid output
    l Steps s mid
    r = RPolish mid output
    l RPolish mid output -> Zip s output -> Zip s output
    forall a b. a -> b -> b
    `seq` [String] -> RPolish mid output -> Steps s mid -> Zip s output
    forall mid output s.
    [String] -> RPolish mid output -> Steps s mid -> Zip s output
    Zip [String]
    errs RPolish mid output
    l Steps s mid
    r

    evalL' :: Zip s output -> Zip s output
    evalL' :: forall s output. Zip s output -> Zip s output
    evalL' (Zip [String]
    errs0 RPolish mid output
    l0 Steps s mid
    r0) = [String] -> RPolish mid output -> Steps s mid -> Zip s output
    forall mid output s.
    [String] -> RPolish mid output -> Steps s mid -> Zip s output
    Zip [String]
    errs0 RPolish mid output
    l0 (Steps s mid -> Steps s mid
    forall s a. Steps s a -> Steps s a
    simplRhs Steps s mid
    r0)
        where simplRhs :: Steps s a ->Steps s a
              simplRhs :: forall s a. Steps s a -> Steps s a
    simplRhs Steps s a
    rhs = case Steps s a
    rhs of
                (Val a
    a Steps s r
    r) -> a -> Steps s r -> Steps s (a :< r)
    forall mid s rest. mid -> Steps s rest -> Steps s (mid :< rest)
    Val a
    a (Steps s r -> Steps s r
    forall s a. Steps s a -> Steps s a
    simplRhs Steps s r
    r)
                (App Steps s ((b -> a) :< (b :< r))
    r)  -> Steps s ((b -> a) :< (b :< r)) -> Steps s (a :< r)
    forall s mid rest a.
    Steps s ((mid -> rest) :< (mid :< a)) -> Steps s (rest :< a)
    App (Steps s ((b -> a) :< (b :< r)) -> Steps s ((b -> a) :< (b :< r))
    forall s a. Steps s a -> Steps s a
    simplRhs Steps s ((b -> a) :< (b :< r))
    r)
                (Shift Steps s a
    p) -> Steps s a -> Steps s a
    forall s a. Steps s a -> Steps s a
    Shift (Steps s a -> Steps s a
    forall s a. Steps s a -> Steps s a
    simplRhs Steps s a
    p)
                (Log String
    err Steps s a
    p) -> String -> Steps s a -> Steps s a
    forall s a. String -> Steps s a -> Steps s a
    Log String
    err (Steps s a -> Steps s a) -> Steps s a -> Steps s a
    forall a b. (a -> b) -> a -> b
    $ Steps s a -> Steps s a
    forall s a. Steps s a -> Steps s a
    simplRhs Steps s a
    p
                (Dislike Steps s a
    p) -> Steps s a -> Steps s a
    forall s a. Steps s a -> Steps s a
    Dislike (Steps s a -> Steps s a) -> Steps s a -> Steps s a
    forall a b. (a -> b) -> a -> b
    $ Steps s a -> Steps s a
    forall s a. Steps s a -> Steps s a
    simplRhs Steps s a
    p
                (Best Ordering
    choice Profile
    _ Steps s a
    p Steps s a
    q) -> case Ordering
    choice of
                    Ordering
    LT -> Steps s a -> Steps s a
    forall s a. Steps s a -> Steps s a
    simplRhs Steps s a
    p
                    Ordering
    GT -> Steps s a -> Steps s a
    forall s a. Steps s a -> Steps s a
    simplRhs Steps s a
    q
                    Ordering
    EQ -> Steps s a -> Steps s a -> Steps s a
    forall s a. Steps s a -> Steps s a -> Steps s a
    iBest (Steps s a -> Steps s a
    forall s a. Steps s a -> Steps s a
    simplRhs Steps s a
    p) (Steps s a -> Steps s a
    forall s a. Steps s a -> Steps s a
    simplRhs Steps s a
    q)
                Steps s a
    x -> Steps s a
    x

    -- | Push some symbols.
    pushSyms :: forall s r. [s] -> Zip s r -> Zip s r
    pushSyms :: forall s r. [s] -> Zip s r -> Zip s r
    pushSyms [s]
    x = Maybe [s] -> Zip s r -> Zip s r
    forall s r. Maybe [s] -> Zip s r -> Zip s r
    feedZ ([s] -> Maybe [s]
    forall a. a -> Maybe a
    Just [s]
    x)

    -- | Push eof
    pushEof :: forall s r. Zip s r -> Zip s r
    pushEof :: forall s output. Zip s output -> Zip s output
    pushEof = Maybe [s] -> Zip s r -> Zip s r
    forall s r. Maybe [s] -> Zip s r -> Zip s r
    feedZ Maybe [s]
    forall a. Maybe a
    Nothing

    -- | Make a parser into a process.
    mkProcess :: forall s a. Parser s a -> Process s a
    mkProcess :: forall s a. Parser s a -> Process s a
    mkProcess Parser s a
    p = [String]
    -> RPolish (a :< ()) (a :< ())
    -> Steps s (a :< ())
    -> Zip s (a :< ())
    forall mid output s.
    [String] -> RPolish mid output -> Steps s mid -> Zip s output
    Zip [] RPolish (a :< ()) (a :< ())
    forall rest. RPolish rest rest
    RStop (Parser s a -> forall r. Steps s r -> Steps s (a :< r)
    forall s a. Parser s a -> forall r. Steps s r -> Steps s (a :< r)
    toP Parser s a
    p Steps s ()
    forall s. Steps s ()
    Done)

    -- | Run a process (in case you do not need the incremental interface)
    run :: Process s a -> [s] -> (a, [String])
    run :: forall s a. Process s a -> [s] -> (a, [String])
    run Process s a
    p [s]
    input = Process s a -> (a, [String])
    forall token a rest. Zip token (a :< rest) -> (a, [String])
    evalR (Process s a -> (a, [String])) -> Process s a -> (a, [String])
    forall a b. (a -> b) -> a -> b
    $ Process s a -> Process s a
    forall s output. Zip s output -> Zip s output
    pushEof (Process s a -> Process s a) -> Process s a -> Process s a
    forall a b. (a -> b) -> a -> b
    $ [s] -> Process s a -> Process s a
    forall s r. [s] -> Zip s r -> Zip s r
    pushSyms [s]
    input Process s a
    p

    testNext :: (Maybe s -> Bool) -> Parser s ()
    testNext :: forall s. (Maybe s -> Bool) -> Parser s ()
    testNext Maybe s -> Bool
    f = Parser s () -> (s -> Parser s ()) -> Parser s ()
    forall s a. Parser s a -> (s -> Parser s a) -> Parser s a
    Look (if Maybe s -> Bool
    f Maybe s
    forall a. Maybe a
    Nothing then Parser s ()
    ok else Parser s ()
    forall a. Parser s a
    forall (f :: * -> *) a. Alternative f => f a
    empty) (\s
    s ->
       if Maybe s -> Bool
    f (Maybe s -> Bool) -> Maybe s -> Bool
    forall a b. (a -> b) -> a -> b
    $ s -> Maybe s
    forall a. a -> Maybe a
    Just s
    s then Parser s ()
    ok else Parser s ()
    forall a. Parser s a
    forall (f :: * -> *) a. Alternative f => f a
    empty)
        where ok :: Parser s ()
    ok = () -> Parser s ()
    forall a. a -> Parser s a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()

    lookNext :: Parser s (Maybe s)
    lookNext :: forall s. Parser s (Maybe s)
    lookNext = Parser s (Maybe s)
    -> (s -> Parser s (Maybe s)) -> Parser s (Maybe s)
    forall s a. Parser s a -> (s -> Parser s a) -> Parser s a
    Look (Maybe s -> Parser s (Maybe s)
    forall a. a -> Parser s a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Maybe s
    forall a. Maybe a
    Nothing) (Maybe s -> Parser s (Maybe s)
    forall a. a -> Parser s a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Maybe s -> Parser s (Maybe s))
    -> (s -> Maybe s) -> s -> Parser s (Maybe s)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . s -> Maybe s
    forall a. a -> Maybe a
    Just)

    -- | Parse the same thing as the argument, but will be used only as
    -- backup. ie, it will be used only if disjuncted with a failing
    -- parser.

    recoverWith :: Parser s a -> Parser s a
    recoverWith :: forall s a. Parser s a -> Parser s a
    recoverWith = String -> Parser s a -> Parser s a
    forall s a. String -> Parser s a -> Parser s a
    Enter String
    "recoverWith" (Parser s a -> Parser s a)
    -> (Parser s a -> Parser s a) -> Parser s a -> Parser s a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Parser s a -> Parser s a
    forall s a. Parser s a -> Parser s a
    Yuck

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

    --------------------------------
    -- The zipper for efficient evaluation:

    -- Arbitrary expressions in Reverse Polish notation.
    -- This can also be seen as an automaton that transforms a stack.
    -- RPolish is indexed by the types in the stack consumed by the automaton (input),
    -- and the stack produced (output)
    data RPolish input output where
      RPush :: a -> RPolish (a :< rest) output -> RPolish rest output
      RApp :: RPolish (b :< rest) output -> RPolish ((a -> b) :< a :< rest) output
      RStop :: RPolish rest rest

    -- Evaluate the output of an RP automaton, given an input stack
    evalRP :: RPolish input output -> input -> output
    evalRP :: forall input output. RPolish input output -> input -> output
    evalRP RPolish input output
    RStop  input
    acc = input
    output
    acc
    evalRP (RPush a
    v RPolish (a :< input) output
    r) input
    acc = RPolish (a :< input) output -> (a :< input) -> output
    forall input output. RPolish input output -> input -> output
    evalRP RPolish (a :< input) output
    r (a
    v a -> input -> a :< input
    forall a b. a -> b -> a :< b
    :< input
    acc)
    evalRP (RApp RPolish (b :< rest) output
    r) ~(a -> b
    f :< ~(a
    a :< rest
    rest)) = RPolish (b :< rest) output -> (b :< rest) -> output
    forall input output. RPolish input output -> input -> output
    evalRP RPolish (b :< rest) output
    r (a -> b
    f a
    a b -> rest -> b :< rest
    forall a b. a -> b -> a :< b
    :< rest
    rest)

    -- execute the automaton as far as possible
    simplify :: RPolish s output -> RPolish s output
    simplify :: forall s output. RPolish s output -> RPolish s output
    simplify (RPush a
    x (RPush a
    f (RApp RPolish (b :< rest) output
    r))) = RPolish s output -> RPolish s output
    forall s output. RPolish s output -> RPolish s output
    simplify (b -> RPolish (b :< s) output -> RPolish s output
    forall mid rest output.
    mid -> RPolish (mid :< rest) output -> RPolish rest output
    RPush (a
    a -> b
    f a
    x) RPolish (b :< s) output
    RPolish (b :< rest) output
    r)
    simplify RPolish s output
    x = RPolish s output
    x

    evalR :: Zip token (a :< rest) -> (a, [String])
    evalR :: forall token a rest. Zip token (a :< rest) -> (a, [String])
    evalR (Zip [String]
    errs RPolish mid (a :< rest)
    l Steps token mid
    r) = (((a :< rest) -> a
    forall a b. (a :< b) -> a
    top ((a :< rest) -> a) -> (mid -> a :< rest) -> mid -> a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . RPolish mid (a :< rest) -> mid -> a :< rest
    forall input output. RPolish input output -> input -> output
    evalRP RPolish mid (a :< rest)
    l) (mid -> a)
    -> ([String] -> [String]) -> (mid, [String]) -> (a, [String])
    forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
    forall (a :: * -> * -> *) b c b' c'.
    Arrow a =>
    a b c -> a b' c' -> a (b, b') (c, c')
    *** ([String]
    errs [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++)) (Steps token mid -> (mid, [String])
    forall s r. Steps s r -> (r, [String])
    evalR' Steps token mid
    r)

    -- Gluing a Polish expression and an RP automaton.
    -- This can also be seen as a zipper of Polish expressions.
    data Zip s output where
       Zip :: [String] -> RPolish mid output -> Steps s mid -> Zip s output
       -- note that the Stack produced by the Polish expression matches
       -- the stack consumed by the RP automaton.

    fullLog :: Zip s output -> ([String],Tree LogEntry)
    fullLog :: forall s output. Zip s output -> ([String], Tree LogEntry)
    fullLog (Zip [String]
    msg RPolish mid output
    _ Steps s mid
    rhs) = ([String] -> [String]
    forall a. [a] -> [a]
    reverse [String]
    msg, Steps s mid -> Tree LogEntry
    forall s r. Steps s r -> Tree LogEntry
    rightLog Steps s mid
    rhs)

    instance Show (Zip s output) where
        show :: Zip s output -> String
    show (Zip [String]
    errs RPolish mid output
    l Steps s mid
    r) = RPolish mid output -> String
    forall a. Show a => a -> String
    show RPolish mid output
    l String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "<>" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Steps s mid -> String
    forall a. Show a => a -> String
    show Steps s mid
    r String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    ", errs = " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ [String] -> String
    forall a. Show a => a -> String
    show [String]
    errs

    onRight :: (forall r. Steps s r -> Steps s r) -> Zip s a -> Zip s a
    onRight :: forall s a.
    (forall r. Steps s r -> Steps s r) -> Zip s a -> Zip s a
    onRight forall r. Steps s r -> Steps s r
    f (Zip [String]
    errs RPolish mid a
    x Steps s mid
    y) = [String] -> RPolish mid a -> Steps s mid -> Zip s a
    forall mid output s.
    [String] -> RPolish mid output -> Steps s mid -> Zip s output
    Zip [String]
    errs RPolish mid a
    x (Steps s mid -> Steps s mid
    forall r. Steps s r -> Steps s r
    f Steps s mid
    y)

    type Process token result = Zip token (result :< ())