{-# LANGUAGE OverloadedStrings, 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
  ( Binding, Binding', binds', whenBack, on, as, run, extend,
    startFrom, revise', justBefore, revise,
    Action
  )

-- | 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 :: [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])

-- | Create a 'SeqBinding' from 'Binding'. The result 'SeqBinding' has
-- no prefixes yet.
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 []

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

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

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

-- | 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 :: [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 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