{-# 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) =
    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)

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

-- | 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 = 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])

-- | 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 = 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 []

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

-- | 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 = 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 []

-- | 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 = 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

-- | 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 = 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

-- | 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) = 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