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