{-# LANGUAGE OverloadedStrings, RankNTypes #-}
module WildBind.Seq
(
prefix,
SeqBinding,
toSeq,
fromSeq,
withPrefix,
withCancel,
reviseSeq
) where
import Control.Monad.Trans.State (State)
import qualified Control.Monad.Trans.State as State
import Data.Monoid (Monoid(..), mconcat)
import Data.Semigroup (Semigroup(..))
import WildBind.Binding
( Binding, Binding', binds', whenBack, on, as, run, extend,
startFrom, revise', justBefore, revise,
Action
)
newtype SeqBinding fs i = SeqBinding ([i] -> Binding' [i] fs i)
instance Ord i => Semigroup (SeqBinding fs i) where
(SeqBinding [i] -> Binding' [i] fs i
a) <> :: SeqBinding fs i -> SeqBinding fs i -> SeqBinding fs i
<> (SeqBinding [i] -> Binding' [i] fs i
b) =
([i] -> Binding' [i] fs i) -> SeqBinding fs i
forall fs i. ([i] -> Binding' [i] fs i) -> SeqBinding fs i
SeqBinding (([i] -> Binding' [i] fs i) -> SeqBinding fs i)
-> ([i] -> Binding' [i] fs i) -> SeqBinding fs i
forall a b. (a -> b) -> a -> b
$ \[i]
ps -> Binding' [i] fs i -> Binding' [i] fs i -> Binding' [i] fs i
forall a. Monoid a => a -> a -> a
mappend ([i] -> Binding' [i] fs i
a [i]
ps) ([i] -> Binding' [i] fs i
b [i]
ps)
instance Ord i => Monoid (SeqBinding fs i) where
mempty :: SeqBinding fs i
mempty = ([i] -> Binding' [i] fs i) -> SeqBinding fs i
forall fs i. ([i] -> Binding' [i] fs i) -> SeqBinding fs i
SeqBinding (([i] -> Binding' [i] fs i) -> SeqBinding fs i)
-> ([i] -> Binding' [i] fs i) -> SeqBinding fs i
forall a b. (a -> b) -> a -> b
$ Binding' [i] fs i -> [i] -> Binding' [i] fs i
forall a b. a -> b -> a
const Binding' [i] fs i
forall a. Monoid a => a
mempty
mappend :: SeqBinding fs i -> SeqBinding fs i -> SeqBinding fs i
mappend = SeqBinding fs i -> SeqBinding fs i -> SeqBinding fs i
forall a. Semigroup a => a -> a -> a
(<>)
withPrefix :: Ord i
=> [i]
-> SeqBinding fs i
-> SeqBinding fs i
withPrefix :: [i] -> SeqBinding fs i -> SeqBinding fs i
withPrefix [i]
ps SeqBinding fs i
sb = (i -> SeqBinding fs i -> SeqBinding fs i)
-> SeqBinding fs i -> [i] -> SeqBinding fs i
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr i -> SeqBinding fs i -> SeqBinding fs i
forall i fs. Ord i => i -> SeqBinding fs i -> SeqBinding fs i
withPrefixSingle SeqBinding fs i
sb [i]
ps
withPrefixSingle :: Ord i => i -> SeqBinding fs i -> SeqBinding fs i
withPrefixSingle :: i -> SeqBinding fs i -> SeqBinding fs i
withPrefixSingle i
p (SeqBinding [i] -> Binding' [i] fs i
fb) =
([i] -> Binding' [i] fs i) -> SeqBinding fs i
forall fs i. ([i] -> Binding' [i] fs i) -> SeqBinding fs i
SeqBinding (([i] -> Binding' [i] fs i) -> SeqBinding fs i)
-> ([i] -> Binding' [i] fs i) -> SeqBinding fs i
forall a b. (a -> b) -> a -> b
$ \[i]
cur_prefix -> [i] -> Binding' [i] fs i
nextBinding [i]
cur_prefix Binding' [i] fs i -> Binding' [i] fs i -> Binding' [i] fs i
forall a. Semigroup a => a -> a -> a
<> [i] -> Binding' [i] fs i
forall fs. [i] -> Binding' [i] fs i
prefixBinding [i]
cur_prefix
where
prefixBinding :: [i] -> Binding' [i] fs i
prefixBinding [i]
cur_prefix = ([i] -> Bool) -> Binding' [i] fs i -> Binding' [i] fs i
forall bs fs i.
(bs -> Bool) -> Binding' bs fs i -> Binding' bs fs i
whenBack ([i] -> [i] -> Bool
forall a. Eq a => a -> a -> Bool
== [i]
cur_prefix) (Binding' [i] fs i -> Binding' [i] fs i)
-> Binding' [i] fs i -> Binding' [i] fs i
forall a b. (a -> b) -> a -> b
$ Binder i (Action (StateT [i] IO) ()) () -> Binding' [i] fs i
forall i bs r a fs.
Ord i =>
Binder i (Action (StateT bs IO) r) a -> Binding' bs fs i
binds' (Binder i (Action (StateT [i] IO) ()) () -> Binding' [i] fs i)
-> Binder i (Action (StateT [i] IO) ()) () -> Binding' [i] fs i
forall a b. (a -> b) -> a -> b
$ do
i
-> Action (StateT [i] IO) ()
-> Binder i (Action (StateT [i] IO) ()) ()
forall i v. i -> v -> Binder i v ()
on i
p `as` ActionDescription
"prefix" (Action (StateT [i] IO) ()
-> Binder i (Action (StateT [i] IO) ()) ())
-> StateT [i] IO () -> Binder i (Action (StateT [i] IO) ()) ()
forall (m :: * -> *) b a.
Functor m =>
(Action m () -> b) -> m a -> b
`run` ([i] -> [i]) -> StateT [i] IO ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify ([i] -> [i] -> [i]
forall a. [a] -> [a] -> [a]
++ [i
p])
nextBinding :: [i] -> Binding' [i] fs i
nextBinding [i]
cur_prefix = [i] -> Binding' [i] fs i
fb ([i]
cur_prefix [i] -> [i] -> [i]
forall a. [a] -> [a] -> [a]
++ [i
p])
toSeq :: Eq i => Binding fs i -> SeqBinding fs i
toSeq :: Binding fs i -> SeqBinding fs i
toSeq Binding fs i
b = ([i] -> Binding' [i] fs i) -> SeqBinding fs i
forall fs i. ([i] -> Binding' [i] fs i) -> SeqBinding fs i
SeqBinding (([i] -> Binding' [i] fs i) -> SeqBinding fs i)
-> ([i] -> Binding' [i] fs i) -> SeqBinding fs i
forall a b. (a -> b) -> a -> b
$ \[i]
ps -> ([i] -> Bool) -> Binding' [i] fs i -> Binding' [i] fs i
forall bs fs i.
(bs -> Bool) -> Binding' bs fs i -> Binding' bs fs i
whenBack ([i] -> [i] -> Bool
forall a. Eq a => a -> a -> Bool
== [i]
ps) (Binding' [i] fs i -> Binding' [i] fs i)
-> Binding' [i] fs i -> Binding' [i] fs i
forall a b. (a -> b) -> a -> b
$ (forall a.
[i]
-> fs
-> i
-> Action (StateT [i] IO) a
-> Maybe (Action (StateT [i] IO) a))
-> Binding' [i] fs i -> Binding' [i] fs i
forall bs fs i.
(forall a.
bs
-> fs
-> i
-> Action (StateT bs IO) a
-> Maybe (Action (StateT bs IO) a))
-> Binding' bs fs i -> Binding' bs fs i
revise' forall a.
[i]
-> fs
-> i
-> Action (StateT [i] IO) a
-> Maybe (Action (StateT [i] IO) a)
forall (m :: * -> *) p p p a a.
Monad m =>
p
-> p
-> p
-> Action (StateT [a] m) a
-> Maybe (Action (StateT [a] m) a)
cancelBefore (Binding' [i] fs i -> Binding' [i] fs i)
-> Binding' [i] fs i -> Binding' [i] fs i
forall a b. (a -> b) -> a -> b
$ Binding fs i -> Binding' [i] fs i
forall fs i bs. Binding fs i -> Binding' bs fs i
extend Binding fs i
b
where
cancelBefore :: p
-> p
-> p
-> Action (StateT [a] m) a
-> Maybe (Action (StateT [a] m) a)
cancelBefore p
_ p
_ p
_ = StateT [a] m ()
-> Action (StateT [a] m) a -> Maybe (Action (StateT [a] m) a)
forall (m :: * -> *) b a.
Applicative m =>
m b -> Action m a -> Maybe (Action m a)
justBefore (StateT [a] m ()
-> Action (StateT [a] m) a -> Maybe (Action (StateT [a] m) a))
-> StateT [a] m ()
-> Action (StateT [a] m) a
-> Maybe (Action (StateT [a] m) a)
forall a b. (a -> b) -> a -> b
$ [a] -> StateT [a] m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put []
fromSeq :: SeqBinding fs i -> Binding fs i
fromSeq :: SeqBinding fs i -> Binding fs i
fromSeq (SeqBinding [i] -> Binding' [i] fs i
fb) = [i] -> Binding' [i] fs i -> Binding fs i
forall bs fs i. bs -> Binding' bs fs i -> Binding fs i
startFrom [] (Binding' [i] fs i -> Binding fs i)
-> Binding' [i] fs i -> Binding fs i
forall a b. (a -> b) -> a -> b
$ [i] -> Binding' [i] fs i
fb []
cancelOn :: Ord i
=> i
-> SeqBinding fs i
cancelOn :: i -> SeqBinding fs i
cancelOn i
c = ([i] -> Binding' [i] fs i) -> SeqBinding fs i
forall fs i. ([i] -> Binding' [i] fs i) -> SeqBinding fs i
SeqBinding (([i] -> Binding' [i] fs i) -> SeqBinding fs i)
-> ([i] -> Binding' [i] fs i) -> SeqBinding fs i
forall a b. (a -> b) -> a -> b
$ Binding' [i] fs i -> [i] -> Binding' [i] fs i
forall a b. a -> b -> a
const (Binding' [i] fs i -> [i] -> Binding' [i] fs i)
-> Binding' [i] fs i -> [i] -> Binding' [i] fs i
forall a b. (a -> b) -> a -> b
$ ([i] -> Bool) -> Binding' [i] fs i -> Binding' [i] fs i
forall bs fs i.
(bs -> Bool) -> Binding' bs fs i -> Binding' bs fs i
whenBack (Bool -> Bool
not (Bool -> Bool) -> ([i] -> Bool) -> [i] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [i] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (Binding' [i] fs i -> Binding' [i] fs i)
-> Binding' [i] fs i -> Binding' [i] fs i
forall a b. (a -> b) -> a -> b
$ Binder i (Action (StateT [i] IO) ()) () -> Binding' [i] fs i
forall i bs r a fs.
Ord i =>
Binder i (Action (StateT bs IO) r) a -> Binding' bs fs i
binds' (Binder i (Action (StateT [i] IO) ()) () -> Binding' [i] fs i)
-> Binder i (Action (StateT [i] IO) ()) () -> Binding' [i] fs i
forall a b. (a -> b) -> a -> b
$ i
-> Action (StateT [i] IO) ()
-> Binder i (Action (StateT [i] IO) ()) ()
forall i v. i -> v -> Binder i v ()
on i
c `as` ActionDescription
"cancel" (Action (StateT [i] IO) ()
-> Binder i (Action (StateT [i] IO) ()) ())
-> StateT [i] IO () -> Binder i (Action (StateT [i] IO) ()) ()
forall (m :: * -> *) b a.
Functor m =>
(Action m () -> b) -> m a -> b
`run` [i] -> StateT [i] IO ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put []
withCancel :: Ord i
=> [i]
-> SeqBinding fs i
-> SeqBinding fs i
withCancel :: [i] -> SeqBinding fs i -> SeqBinding fs i
withCancel [i]
cs SeqBinding fs i
sb = SeqBinding fs i
forall fs. SeqBinding fs i
cancelBindings SeqBinding fs i -> SeqBinding fs i -> SeqBinding fs i
forall a. Semigroup a => a -> a -> a
<> SeqBinding fs i
sb
where
cancelBindings :: SeqBinding fs i
cancelBindings = [SeqBinding fs i] -> SeqBinding fs i
forall a. Monoid a => [a] -> a
mconcat ([SeqBinding fs i] -> SeqBinding fs i)
-> [SeqBinding fs i] -> SeqBinding fs i
forall a b. (a -> b) -> a -> b
$ (i -> SeqBinding fs i) -> [i] -> [SeqBinding fs i]
forall a b. (a -> b) -> [a] -> [b]
map i -> SeqBinding fs i
forall i fs. Ord i => i -> SeqBinding fs i
cancelOn [i]
cs
prefix :: Ord i
=> [i]
-> [i]
-> Binding fs i
-> Binding fs i
prefix :: [i] -> [i] -> Binding fs i -> Binding fs i
prefix [i]
cs [i]
ps = SeqBinding fs i -> Binding fs i
forall fs i. SeqBinding fs i -> Binding fs i
fromSeq (SeqBinding fs i -> Binding fs i)
-> (Binding fs i -> SeqBinding fs i)
-> Binding fs i
-> Binding fs i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [i] -> SeqBinding fs i -> SeqBinding fs i
forall i fs. Ord i => [i] -> SeqBinding fs i -> SeqBinding fs i
withCancel [i]
cs (SeqBinding fs i -> SeqBinding fs i)
-> (Binding fs i -> SeqBinding fs i)
-> Binding fs i
-> SeqBinding fs i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [i] -> SeqBinding fs i -> SeqBinding fs i
forall i fs. Ord i => [i] -> SeqBinding fs i -> SeqBinding fs i
withPrefix [i]
ps (SeqBinding fs i -> SeqBinding fs i)
-> (Binding fs i -> SeqBinding fs i)
-> Binding fs i
-> SeqBinding fs i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binding fs i -> SeqBinding fs i
forall i fs. Eq i => Binding fs i -> SeqBinding fs i
toSeq
reviseSeq :: (forall a . [i] -> fs -> i -> Action IO a -> Maybe (Action IO a))
-> SeqBinding fs i
-> SeqBinding fs i
reviseSeq :: (forall a. [i] -> fs -> i -> Action IO a -> Maybe (Action IO a))
-> SeqBinding fs i -> SeqBinding fs i
reviseSeq forall a. [i] -> fs -> i -> Action IO a -> Maybe (Action IO a)
f (SeqBinding [i] -> Binding' [i] fs i
orig) = ([i] -> Binding' [i] fs i) -> SeqBinding fs i
forall fs i. ([i] -> Binding' [i] fs i) -> SeqBinding fs i
SeqBinding (([i] -> Binding' [i] fs i) -> SeqBinding fs i)
-> ([i] -> Binding' [i] fs i) -> SeqBinding fs i
forall a b. (a -> b) -> a -> b
$ (Binding' [i] fs i -> Binding' [i] fs i)
-> ([i] -> Binding' [i] fs i) -> [i] -> Binding' [i] fs i
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall a. [i] -> fs -> i -> Action IO a -> Maybe (Action IO a))
-> Binding' [i] fs i -> Binding' [i] fs i
forall bs fs i.
(forall a. bs -> fs -> i -> Action IO a -> Maybe (Action IO a))
-> Binding' bs fs i -> Binding' bs fs i
revise forall a. [i] -> fs -> i -> Action IO a -> Maybe (Action IO a)
f) [i] -> Binding' [i] fs i
orig