{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
-- |
-- Module: WildBind.Seq
-- Description: Support for binding sequence of input events.
-- Maintainer: Toshio Ito <debug.ito@gmail.com>
--
-- This module defines convenient functions to build 'Binding's that
-- bind actions to key sequences.
--
-- For example, see
-- [WildBind.Task.X11.Seq.Example in wild-bind-task-x11](https://hackage.haskell.org/package/wild-bind-task-x11/docs/WildBind-Task-X11-Seq-Example.html) package.
--
-- @since 0.1.1.0
--

module WildBind.Seq
    ( -- * Simple API
      prefix
      -- * Advanced API
    , 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)

-- | Intermediate type of building a 'Binding' for key sequences.
newtype SeqBinding fs i
  = SeqBinding ([i] -> Binding' [i] fs i)

-- | Follows the same rule as 'Binding'.
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)

-- | Follows the same rule as 'Binding'.
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
(<>)

-- | Prepend prefix keys to the 'SeqBinding'.
--
-- 'SeqBinding' is composable in terms of prefixes, that is,
--
-- > (withPrefix [key1, key2] seq_b) == (withPrefix [key1] $ withPrefix [key2] seq_b)
withPrefix :: Ord i
           => [i] -- ^ prefix keys
           -> 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 = (i -> SeqBinding fs i -> SeqBinding fs i)
-> SeqBinding fs i -> [i] -> SeqBinding fs i
forall a b. (a -> b -> b) -> b -> [a] -> b
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 :: forall i fs. Ord i => 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])

-- | Create a 'SeqBinding' from 'Binding'. The result 'SeqBinding' has
-- no prefixes yet.
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 = ([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' [i]
-> fs
-> i
-> Action (StateT [i] IO) a
-> Maybe (Action (StateT [i] IO) a)
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 []

-- | Resolve 'SeqBinding' to build a 'Binding' for key sequences.
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) = [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 []

-- | A 'SeqBinding' that binds the given key for canceling the key
-- sequence.
cancelOn :: Ord i
         => i -- ^ cancel key
         -> SeqBinding fs i
cancelOn :: forall i fs. Ord i => 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 a. [a] -> 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 []

-- | Add cancel keys to the 'SeqBinding'.
withCancel :: Ord i
           => [i] -- ^ cancel keys
           -> 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 = 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

-- | Prepend prefix keys to a 'Binding'. In the result 'Binding', the
-- original 'Binding' is enabled only after you input the prefix input
-- symbols in the same order.
--
-- During typing prefix keys, you can cancel and reset the key
-- sequence by typing the \"cancel keys\". This is analogous to @C-g@
-- in Emacs. The binding of cancel keys are weak, that is, they are
-- overridden by the original binding and prefix keys.
--
-- Note that this function creates an independent implicit state to
-- memorize prefix keys input so far. This means,
--
-- > (prefix [] [key1, key2] b) /= (prefix [] [key1] $ prefix [] [key2] b)
--
-- If you want a more composable way of building a sequence binding,
-- try 'SeqBinding'.
prefix :: Ord i
       => [i] -- ^ The cancel keys (input symbols for canceling the current key sequence.)
       -> [i] -- ^ list of prefix input symbols
       -> Binding fs i -- ^ the original binding.
       -> Binding fs i -- ^ the result binding.
prefix :: forall i fs. Ord i => [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

-- | Revise actions in 'SeqBinding'. See 'WildBind.Binding.revise'.
reviseSeq :: (forall a . [i] -> fs -> i -> Action IO a -> Maybe (Action IO a))
             -- ^ Revising function. @[i]@ is the prefix keys input so far.
          -> 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) = ([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 a b. (a -> b) -> ([i] -> a) -> [i] -> b
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 [i] -> fs -> i -> Action IO a -> Maybe (Action IO a)
forall a. [i] -> fs -> i -> Action IO a -> Maybe (Action IO a)
f) [i] -> Binding' [i] fs i
orig