{-# 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 = (:<) {(a :< b) -> a
top :: a, (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
showList :: [ProfileF a] -> ShowS
$cshowList :: forall a. Show a => [ProfileF a] -> ShowS
show :: ProfileF a -> String
$cshow :: forall a. Show a => ProfileF a -> String
showsPrec :: Int -> ProfileF a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ProfileF a -> ShowS
Show, a -> ProfileF b -> ProfileF a
(a -> b) -> ProfileF a -> ProfileF b
(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
<$ :: a -> ProfileF b -> ProfileF a
$c<$ :: forall a b. a -> ProfileF b -> ProfileF a
fmap :: (a -> b) -> ProfileF a -> ProfileF b
$cfmap :: forall a b. (a -> b) -> ProfileF a -> ProfileF b
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 n :: Int
n
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 5 = 0
    | Bool
otherwise = -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 _ PFail p :: Profile
p = (Ordering
GT, Profile
p) -- avoid failure
better _ p :: Profile
p PFail = (Ordering
LT, Profile
p)
better _ PSusp _ = (Ordering
EQ, Profile
forall a. ProfileF a
PSusp) -- could not decide before suspension => leave undecided.
better _ _ PSusp = (Ordering
EQ, Profile
forall a. ProfileF a
PSusp)
better _ (PRes x :: Int
x) (PRes y :: 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 lk :: Int
lk xs :: Profile
xs@(PRes x :: Int
x) (y :: Int
y:>ys :: Profile
ys) = if Int
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 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
+1) Profile
xs Profile
ys
better lk :: Int
lk (y :: Int
y:>ys :: Profile
ys) xs :: Profile
xs@(PRes x :: Int
x) = if Int
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 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
+1) Profile
ys Profile
xs
better lk :: Int
lk (x :: Int
x:>xs :: Profile
xs) (y :: Int
y:>ys :: Profile
ys)
    | Int
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
&& Int
y Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 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
+ 1) Profile
xs Profile
ys

(+>) :: Int -> (t, Profile) -> (t, Profile)
x :: Int
x +> :: Int -> (t, Profile) -> (t, Profile)
+> ~(ordering :: t
ordering, xs :: 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
showList :: [LogEntry] -> ShowS
$cshowList :: [LogEntry] -> ShowS
show :: LogEntry -> String
$cshow :: LogEntry -> String
showsPrec :: Int -> LogEntry -> ShowS
$cshowsPrec :: Int -> LogEntry -> ShowS
Show

rightLog :: Steps s r -> Tree LogEntry
rightLog :: Steps s r -> Tree LogEntry
rightLog (Val _ p :: Steps s r
p) = Steps s r -> Tree LogEntry
forall s r. Steps s r -> Tree LogEntry
rightLog Steps s r
p
rightLog (App p :: 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 p :: Steps s r
p) = LogEntry -> Forest LogEntry -> Tree LogEntry
forall a. a -> Forest 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 -> Forest LogEntry -> Tree LogEntry
forall a. a -> Forest a -> Tree a
Node LogEntry
LDone []
rightLog (Steps s r
Fail) = LogEntry -> Forest LogEntry -> Tree LogEntry
forall a. a -> Forest a -> Tree a
Node LogEntry
LFail []
rightLog (Dislike p :: Steps s r
p) = LogEntry -> Forest LogEntry -> Tree LogEntry
forall a. a -> Forest 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 msg :: String
msg p :: Steps s r
p) = LogEntry -> Forest LogEntry -> Tree LogEntry
forall a. a -> Forest 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 _ _) = LogEntry -> Forest LogEntry -> Tree LogEntry
forall a. a -> Forest a -> Tree a
Node LogEntry
LSusp []
rightLog (Best _ _ l :: Steps s r
l r :: Steps s r
r) = LogEntry -> Forest LogEntry -> Tree LogEntry
forall a. a -> Forest 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 -> Forest LogEntry -> Forest 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' _) = String -> Tree LogEntry
forall a. HasCallStack => String -> a
error "Sh' should be hidden by Sus"

profile :: Steps s r -> Profile
profile :: Steps s r -> Profile
profile (Val _ p :: Steps s r
p) = Steps s r -> Profile
forall s r. Steps s r -> Profile
profile Steps s r
p
profile (App p :: 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 p :: Steps s r
p) = 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 0 -- success with zero dislikes
profile (Steps s r
Fail) = Profile
forall a. ProfileF a
PFail
profile (Dislike p :: Steps s r
p) = (Int -> Int) -> Profile -> Profile
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 _ p :: Steps s r
p) = Steps s r -> Profile
forall s r. Steps s r -> Profile
profile Steps s r
p
profile (Sus _ _) = Profile
forall a. ProfileF a
PSusp
profile (Best _ pr :: Profile
pr _ _) = Profile
pr
profile (Sh' _) = String -> Profile
forall a. HasCallStack => String -> a
error "Sh' should be hidden by Sus"

instance Show (Steps s r) where
    show :: Steps s r -> String
show (Val _ p :: Steps s r
p) = '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 p :: Steps s ((b -> a) :< (b :< r))
p) = '*' 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) = "1"
    show (Shift p :: Steps s r
p) = '>' Char -> ShowS
forall a. a -> [a] -> [a]
: Steps s r -> String
forall a. Show a => a -> String
show Steps s r
p
    show (Sh' p :: Steps s r
p) = '\'' Char -> ShowS
forall a. a -> [a] -> [a]
: Steps s r -> String
forall a. Show a => a -> String
show Steps s r
p
    show (Dislike p :: Steps s r
p) = '?' Char -> ShowS
forall a. a -> [a] -> [a]
: Steps s r -> String
forall a. Show a => a -> String
show Steps s r
p
    show (Log msg :: String
msg p :: Steps s r
p) = "[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg String -> ShowS
forall a. [a] -> [a] -> [a]
++ "]"  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) = "0"
    show (Sus _ _) = "..."
    show (Best _ _ p :: Steps s r
p q :: Steps s r
q) = "(" 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 -> 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 :: Zip s r -> Int
countWidth (Zip _ _ 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' :: Steps s r -> Int
countWidth' r' :: Steps s r
r' = case Steps s r
r' of
            (Best _ _ p :: Steps s r
p q :: 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 _ p :: Steps s r
p) -> Steps s r -> Int
forall s r. Steps s r -> Int
countWidth' Steps s r
p
            (App p :: 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) -> 1
            (Shift p :: Steps s r
p) -> Steps s r -> Int
forall s r. Steps s r -> Int
countWidth' Steps s r
p
            (Sh' p :: Steps s r
p) -> Steps s r -> Int
forall s r. Steps s r -> Int
countWidth' Steps s r
p
            (Dislike p :: Steps s r
p) -> Steps s r -> Int
forall s r. Steps s r -> Int
countWidth' Steps s r
p
            (Log _ p :: Steps s r
p) -> Steps s r -> Int
forall s r. Steps s r -> Int
countWidth' Steps s r
p
            (Steps s r
Fail) -> 1
            (Sus _ _) -> 1

instance Show (RPolish i o) where
    show :: RPolish i o -> String
show (RPush _ p :: 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]
++ "^"
    show (RApp p :: 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]
++ "@"
    show (RPolish i o
RStop) = "!"


apply :: forall t t1 a. ((t -> a) :< (t :< t1)) -> a :< t1
apply :: ((t -> a) :< (t :< t1)) -> a :< t1
apply ~(f :: t -> a
f:< ~(a :: t
a:<r :: 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' :: Steps s r -> (r, [String])
evalR' Done = ((), [])
evalR' (Val a :: a
a r :: Steps s r
r) = (r -> a :< r) -> (r, [String]) -> (r, [String])
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 s :: Steps s ((b -> a) :< (b :< r))
s) = (((b -> a) :< (b :< r)) -> a :< r)
-> ((b -> a) :< (b :< r), [String]) -> (r, [String])
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 v :: Steps s r
v) = Steps s r -> (r, [String])
forall s r. Steps s r -> (r, [String])
evalR' Steps s r
v
evalR' (Dislike v :: Steps s r
v) = Steps s r -> (r, [String])
forall s r. Steps s r -> (r, [String])
evalR' Steps s r
v
evalR' (Log err :: String
err v :: Steps s r
v) = ([String] -> [String]) -> (r, [String]) -> (r, [String])
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 "evalR: No parse!"
evalR' (Sus _ _) = String -> (r, [String])
forall a. HasCallStack => String -> a
error "evalR: Not fully evaluated!"
evalR' (Sh' _) = String -> (r, [String])
forall a. HasCallStack => String -> a
error "evalR: Sh' should be hidden by Sus"
evalR' (Best choice :: Ordering
choice _ p :: Steps s r
p q :: Steps s r
q) = case Ordering
choice of
    LT -> Steps s r -> (r, [String])
forall s r. Steps s r -> (r, [String])
evalR' Steps s r
p
    GT -> Steps s r -> (r, [String])
forall s r. Steps s r -> (r, [String])
evalR' Steps s r
q
    EQ -> String -> (r, [String])
forall a. HasCallStack => String -> a
error (String -> (r, [String])) -> String -> (r, [String])
forall a b. (a -> b) -> a -> b
$ "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 -> 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 :: (a -> b) -> Parser s a -> Parser s b
fmap f :: a -> b
f = ((a -> b) -> Parser s (a -> b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> b
f 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
    <*> :: 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 :: a -> Parser s a
pure = a -> Parser s a
forall a s. a -> Parser s a
Pure

instance Alternative (Parser s) where
    <|> :: 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 :: Parser s a
empty = Parser s a
forall s a. Parser s a
Empt

instance Monad (Parser s) where
    >>= :: 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 :: a -> Parser s a
return = 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 :: String -> Parser s a
fail _message :: 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 :: Parser s a -> forall h r. ((h, a) -> Steps s r) -> h -> Steps s r
toQ (Look a :: Parser s a
a f :: s -> Parser s a
f) = \k :: (h, a) -> Steps s r
k h :: 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 -> ((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
s -> Parser s a -> ((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 (p :: Parser s (b -> a)
p `Appl` q :: Parser s b
q) = \k :: (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
h, b2a :: b -> a
b2a), b :: b
b) -> (h, a) -> Steps s r
k (h
h, b -> a
b2a b
b)
toQ (Pure a :: a
a)     = \k :: (h, a) -> Steps s r
k h :: h
h -> (h, a) -> Steps s r
k (h
h, a
a)
toQ (Disj p :: Parser s a
p q :: Parser s a
q)   = \k :: (h, a) -> Steps s r
k h :: 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 -> ((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 -> ((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 p :: Parser s a
p a2q :: a -> Parser s a
a2q) = \k :: (h, a) -> Steps s r
k -> Parser s a -> ((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
h,a :: a
a) -> Parser s a -> ((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 Empt = \_k :: (h, a) -> Steps s r
_k _h :: h
_h -> Steps s r
forall s a. Steps s a
Fail
toQ (Yuck p :: Parser s a
p) = \k :: (h, a) -> Steps s r
k h :: 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 -> ((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 err :: String
err p :: Parser s a
p) = \k :: (h, a) -> Steps s r
k h :: 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 -> ((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 p :: Parser s a
p) = \k :: (h, a) -> Steps s r
k h :: 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 -> ((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 :: Parser s a -> forall r. Steps s r -> Steps s (a :< r)
toP (Look a :: Parser s a
a f :: s -> Parser s a
f) = {-# SCC "toP_Look" #-} \fut :: 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 -> 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
s -> Parser s a -> 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 f :: Parser s (b -> a)
f x :: Parser s b
x) = {-# SCC "toP_Appl" #-} Steps s ((b -> a) :< (b :< r)) -> Steps s (a :< r)
forall s b a r. Steps s ((b -> a) :< (b :< r)) -> Steps s (a :< r)
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 x :: a
x)   = {-# SCC "toP_Pure" #-} a -> Steps s r -> Steps s (a :< r)
forall a s r. a -> Steps s r -> Steps s (a :< r)
Val a
x
toP 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 a :: Parser s a
a b :: Parser s a
b)  = {-# SCC "toP_Disj" #-} \fut :: 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 -> 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 -> 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 p :: Parser s a
p a2q :: a -> Parser s a
a2q) = {-# SCC "toP_Bind" #-} \fut :: Steps s r
fut -> Parser s a
-> (((), a) -> Steps s (a :< r)) -> () -> Steps s (a :< 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
a) -> Parser s a -> 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 p :: 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 err :: String
err p :: 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 p :: 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 :: Steps s a -> Steps s a -> Steps s a
iBest p :: Steps s a
p q :: Steps s a
q = let ~(choice :: Ordering
choice, pr :: Profile
pr) = Int -> Profile -> Profile -> (Ordering, Profile)
better 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 :: (s -> Bool) -> Parser s s
symbol f :: 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 (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
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 (f :: * -> *) a. Applicative f => a -> f a
pure s
s else Parser s s
forall (f :: * -> *) a. Alternative f => f a
empty

eof :: forall s. Parser s ()
eof :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure ()) (Parser s () -> s -> Parser s ()
forall a b. a -> b -> a
const Parser s ()
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 :: Maybe [s] -> Steps s r -> Steps s r
feed (Just []) p :: Steps s r
p = Steps s r
p  -- nothing more left to feed
feed ss :: Maybe [s]
ss p :: Steps s r
p = case Steps s r
p of
                  (Sus nil :: Steps s r
nil cons :: s -> Steps s r
cons) -> case Maybe [s]
ss of
                      Just [] -> Steps s r
p -- no more info, stop feeding
                      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 p' :: 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' p' :: 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> [s] -> [s]
forall a. Int -> [a] -> [a]
drop 1) Maybe [s]
ss) Steps s r
p')
                  (Dislike p' :: 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 err :: String
err p' :: 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 x :: a
x p' :: Steps s r
p') -> a -> Steps s r -> Steps s (a :< r)
forall a s r. a -> Steps s r -> Steps s (a :< r)
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 p' :: Steps s ((b -> a) :< (b :< r))
p') -> Steps s ((b -> a) :< (b :< r)) -> Steps s (a :< r)
forall s b a r. Steps s ((b -> a) :< (b :< r)) -> Steps s (a :< r)
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')
                  Done -> Steps s r
forall s. Steps s ()
Done
                  Fail -> Steps s r
forall s a. Steps s a
Fail
                  Best _ _ p' :: Steps s r
p' q' :: 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 :: Maybe [s] -> Zip s r -> Zip s r
feedZ x :: 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 :: Zip s output -> Zip s output
evalL (Zip errs0 :: [String]
errs0 l0 :: RPolish mid output
l0 r0 :: 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 :: [String] -> RPolish mid output -> Steps s mid -> Zip s output
help errs :: [String]
errs l :: RPolish mid output
l rhs :: Steps s mid
rhs = case Steps s mid
rhs of
          (Val a :: a
a r :: 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 a rest output.
a -> RPolish (a :< rest) output -> RPolish rest output
RPush a
a RPolish mid output
RPolish (a :< r) output
l)) Steps s r
r
          (App r :: 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 b rest output a.
RPolish (b :< rest) output
-> RPolish ((a -> b) :< (a :< rest)) output
RApp RPolish mid output
RPolish (a :< r) output
l) Steps s ((b -> a) :< (b :< r))
r
          (Shift p :: 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 err :: String
err p :: 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 p :: 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 choice :: Ordering
choice _ p :: Steps s mid
p q :: Steps s mid
q) -> case Ordering
choice of
              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
              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
              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.
          _ -> [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 :: [String] -> RPolish mid output -> Steps s mid -> Zip s output
reZip errs :: [String]
errs l :: RPolish mid output
l r :: 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' :: Zip s output -> Zip s output
evalL' (Zip errs0 :: [String]
errs0 l0 :: RPolish mid output
l0 r0 :: 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 :: Steps s a -> Steps s a
simplRhs rhs :: Steps s a
rhs = case Steps s a
rhs of
            (Val a :: a
a r :: Steps s r
r) -> a -> Steps s r -> Steps s (a :< r)
forall a s r. a -> Steps s r -> Steps s (a :< r)
Val a
a (Steps s r -> Steps s r
forall s a. Steps s a -> Steps s a
simplRhs Steps s r
r)
            (App r :: Steps s ((b -> a) :< (b :< r))
r)  -> Steps s ((b -> a) :< (b :< r)) -> Steps s (a :< r)
forall s b a r. Steps s ((b -> a) :< (b :< r)) -> Steps s (a :< r)
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 p :: 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 err :: String
err p :: 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 p :: 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 choice :: Ordering
choice _ p :: Steps s a
p q :: Steps s a
q) -> case Ordering
choice of
                LT -> Steps s a -> Steps s a
forall s a. Steps s a -> Steps s a
simplRhs Steps s a
p
                GT -> Steps s a -> Steps s a
forall s a. Steps s a -> Steps s a
simplRhs Steps s a
q
                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)
            x :: Steps s a
x -> Steps s a
x

-- | Push some symbols.
pushSyms :: forall s r. [s] -> Zip s r -> Zip s r
pushSyms :: [s] -> Zip s r -> Zip s r
pushSyms x :: [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 :: Zip s r -> Zip s r
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 :: Parser s a -> Process s a
mkProcess p :: Parser s a
p = [String]
-> RPolish (a :< ()) (a :< ()) -> Steps s (a :< ()) -> Process 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 -> Steps s () -> Steps s (a :< ())
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 :: Process s a -> [s] -> (a, [String])
run p :: Process s a
p input :: [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 r. Zip s r -> Zip s r
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 :: (Maybe s -> Bool) -> Parser s ()
testNext f :: 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 (f :: * -> *) a. Alternative f => f a
empty) (\s :: 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 (f :: * -> *) a. Alternative f => f a
empty)
    where ok :: Parser s ()
ok = () -> Parser s ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

lookNext :: Parser s (Maybe s)
lookNext :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure Maybe s
forall a. Maybe a
Nothing) (Maybe s -> Parser s (Maybe s)
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 :: 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 "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 :: RPolish input output -> input -> output
evalRP RStop  acc :: input
acc = input
output
acc
evalRP (RPush v :: a
v r :: RPolish (a :< input) output
r) acc :: 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 r :: RPolish (b :< rest) output
r) ~(f :< ~(a :< 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 :: RPolish s output -> RPolish s output
simplify (RPush x :: a
x (RPush f :: a
f (RApp r :: RPolish (b :< rest) output
r))) = RPolish rest output -> RPolish rest output
forall s output. RPolish s output -> RPolish s output
simplify (b -> RPolish (b :< rest) output -> RPolish rest output
forall a rest output.
a -> RPolish (a :< rest) output -> RPolish rest output
RPush (a
a -> b
f a
x) RPolish (b :< rest) output
r)
simplify x :: RPolish s output
x = RPolish s output
x

evalR :: Zip token (a :< rest) -> (a, [String])
evalR :: Zip token (a :< rest) -> (a, [String])
evalR (Zip errs :: [String]
errs l :: RPolish mid (a :< rest)
l r :: 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 (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 :: Zip s output -> ([String], Tree LogEntry)
fullLog (Zip msg :: [String]
msg _ rhs :: 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 errs :: [String]
errs l :: RPolish mid output
l r :: 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 -> 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]
++ ", 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 r. Steps s r -> Steps s r) -> Zip s a -> Zip s a
onRight f :: forall r. Steps s r -> Steps s r
f (Zip errs :: [String]
errs x :: RPolish mid a
x y :: 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 :< ())