{-|
Module      : KMonad.Button
Description : How buttons work
Copyright   : (c) David Janssen, 2019
License     : MIT
Maintainer  : janssen.dhj@gmail.com
Stability   : experimental
Portability : portable

A button contains 2 actions, one to perform on press, and another to perform on
release. This module contains that definition, and some helper code that helps
combine buttons. It is here that most of the complicated` buttons are
implemented (like TapHold).

-}
module KMonad.Button
  ( -- * Button basics
    -- $but
    Button
  , HasButton(..)
  , onPress
  , mkButton
  , around
  , tapOn

  -- * Simple buttons
  -- $simple
  , emitB
  , modded
  , layerToggle
  , layerSwitch
  , layerAdd
  , layerRem
  , pass
  , cmdButton

  -- * Button combinators
  -- $combinators
  , aroundNext
  , layerDelay
  , layerNext
  , tapHold
  , multiTap
  , tapNext
  , tapHoldNext
  , tapNextRelease
  , tapHoldNextRelease
  , tapMacro
  )
where

import KMonad.Prelude

import KMonad.Action
import KMonad.Keyboard
import KMonad.Util


--------------------------------------------------------------------------------
-- $but
--
-- This section contains the basic definition of KMonad's 'Button' datatype. A
-- 'Button' is essentially a collection of 2 different actions, 1 to perform on
-- 'Press' and another on 'Release'.

-- | A 'Button' consists of two 'MonadK' actions, one to take when a press is
-- registered from the OS, and another when a release is registered.
data Button = Button
  { Button -> Action
_pressAction   :: !Action -- ^ Action to take when pressed
  , Button -> Action
_releaseAction :: !Action -- ^ Action to take when released
  }
makeClassy ''Button

-- | Create a 'Button' out of a press and release action
--
-- NOTE: Since 'AnyK' is an existentially qualified 'MonadK', the monadic
-- actions specified must be runnable by all implementations of 'MonadK', and
-- therefore can only rely on functionality from 'MonadK'. I.e. the actions must
-- be pure 'MonadK'.
mkButton :: AnyK () -> AnyK () -> Button
mkButton :: AnyK () -> AnyK () -> Button
mkButton a :: AnyK ()
a b :: AnyK ()
b = Action -> Action -> Button
Button (AnyK () -> Action
Action AnyK ()
a) (AnyK () -> Action
Action AnyK ()
b)

-- | Create a new button with only a 'Press' action
onPress :: AnyK () -> Button
onPress :: AnyK () -> Button
onPress p :: AnyK ()
p = AnyK () -> AnyK () -> Button
mkButton AnyK ()
p (AnyK () -> Button) -> AnyK () -> Button
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


--------------------------------------------------------------------------------
-- $running
--
-- Triggering the actions stored in a 'Button'.

-- | Perform both the press and release of a button immediately
tap :: MonadK m => Button -> m ()
tap :: Button -> m ()
tap b :: Button
b = do
  Action -> m ()
Action -> AnyK ()
runAction (Action -> m ()) -> Action -> m ()
forall a b. (a -> b) -> a -> b
$ Button
bButton -> Getting Action Button Action -> Action
forall s a. s -> Getting a s a -> a
^.Getting Action Button Action
forall c. HasButton c => Lens' c Action
pressAction
  Action -> m ()
Action -> AnyK ()
runAction (Action -> m ()) -> Action -> m ()
forall a b. (a -> b) -> a -> b
$ Button
bButton -> Getting Action Button Action -> Action
forall s a. s -> Getting a s a -> a
^.Getting Action Button Action
forall c. HasButton c => Lens' c Action
releaseAction

-- | Perform the press action of a Button and register its release callback.
--
-- This performs the action stored in the 'pressAction' field and registers a
-- callback that will trigger the 'releaseAction' when the release is detected.
press :: MonadK m => Button -> m ()
press :: Button -> m ()
press b :: Button
b = do
  Action -> m ()
Action -> AnyK ()
runAction (Action -> m ()) -> Action -> m ()
forall a b. (a -> b) -> a -> b
$ Button
bButton -> Getting Action Button Action -> Action
forall s a. s -> Getting a s a -> a
^.Getting Action Button Action
forall c. HasButton c => Lens' c Action
pressAction
  Switch -> m Catch -> m ()
forall (m :: * -> *). MonadK m => Switch -> m Catch -> m ()
awaitMy Switch
Release (m Catch -> m ()) -> m Catch -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Action -> m ()
Action -> AnyK ()
runAction (Action -> m ()) -> Action -> m ()
forall a b. (a -> b) -> a -> b
$ Button
bButton -> Getting Action Button Action -> Action
forall s a. s -> Getting a s a -> a
^.Getting Action Button Action
forall c. HasButton c => Lens' c Action
releaseAction
    Catch -> m Catch
forall (f :: * -> *) a. Applicative f => a -> f a
pure Catch
Catch

--------------------------------------------------------------------------------
-- $simple
--
-- A collection of simple buttons. These are basically almost direct wrappings
-- around 'MonadK' functionality.

-- | A button that emits a Press of a keycode when pressed, and a release when
-- released.
emitB :: Keycode -> Button
emitB :: Keycode -> Button
emitB c :: Keycode
c = AnyK () -> AnyK () -> Button
mkButton
  (KeyEvent -> m ()
forall (m :: * -> *). MonadKIO m => KeyEvent -> m ()
emit (KeyEvent -> m ()) -> KeyEvent -> m ()
forall a b. (a -> b) -> a -> b
$ Keycode -> KeyEvent
mkPress Keycode
c)
  (KeyEvent -> m ()
forall (m :: * -> *). MonadKIO m => KeyEvent -> m ()
emit (KeyEvent -> m ()) -> KeyEvent -> m ()
forall a b. (a -> b) -> a -> b
$ Keycode -> KeyEvent
mkRelease Keycode
c)

-- | Create a new button that first presses a 'Keycode' before running an inner
-- button, releasing the 'Keycode' again after the inner 'Button' is released.
modded ::
     Keycode -- ^ The 'Keycode' to `wrap around` the inner button
  -> Button  -- ^ The button to nest inside `being modded`
  -> Button
modded :: Keycode -> Button -> Button
modded modder :: Keycode
modder = Button -> Button -> Button
around (Keycode -> Button
emitB Keycode
modder)

-- | Create a button that toggles a layer on and off
layerToggle :: LayerTag -> Button
layerToggle :: LayerTag -> Button
layerToggle t :: LayerTag
t = AnyK () -> AnyK () -> Button
mkButton
  (LayerOp -> m ()
forall (m :: * -> *). MonadKIO m => LayerOp -> m ()
layerOp (LayerOp -> m ()) -> LayerOp -> m ()
forall a b. (a -> b) -> a -> b
$ LayerTag -> LayerOp
PushLayer LayerTag
t)
  (LayerOp -> m ()
forall (m :: * -> *). MonadKIO m => LayerOp -> m ()
layerOp (LayerOp -> m ()) -> LayerOp -> m ()
forall a b. (a -> b) -> a -> b
$ LayerTag -> LayerOp
PopLayer  LayerTag
t)

-- | Create a button that switches the base-layer on a press
layerSwitch :: LayerTag -> Button
layerSwitch :: LayerTag -> Button
layerSwitch t :: LayerTag
t = AnyK () -> Button
onPress (LayerOp -> m ()
forall (m :: * -> *). MonadKIO m => LayerOp -> m ()
layerOp (LayerOp -> m ()) -> LayerOp -> m ()
forall a b. (a -> b) -> a -> b
$ LayerTag -> LayerOp
SetBaseLayer LayerTag
t)

-- | Create a button that adds a layer on a press
layerAdd :: LayerTag -> Button
layerAdd :: LayerTag -> Button
layerAdd t :: LayerTag
t = AnyK () -> Button
onPress (LayerOp -> m ()
forall (m :: * -> *). MonadKIO m => LayerOp -> m ()
layerOp (LayerOp -> m ()) -> LayerOp -> m ()
forall a b. (a -> b) -> a -> b
$ LayerTag -> LayerOp
PushLayer LayerTag
t)

-- | Create a button that removes the top instance of a layer on a press
layerRem :: LayerTag -> Button
layerRem :: LayerTag -> Button
layerRem t :: LayerTag
t = AnyK () -> Button
onPress (LayerOp -> m ()
forall (m :: * -> *). MonadKIO m => LayerOp -> m ()
layerOp (LayerOp -> m ()) -> LayerOp -> m ()
forall a b. (a -> b) -> a -> b
$ LayerTag -> LayerOp
PopLayer LayerTag
t)

-- | Create a button that does nothing (but captures the input)
pass :: Button
pass :: Button
pass = AnyK () -> Button
onPress (AnyK () -> Button) -> AnyK () -> Button
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Create a button that executes a shell command on press
cmdButton :: Text -> Button
cmdButton :: LayerTag -> Button
cmdButton t :: LayerTag
t = AnyK () -> Button
onPress (AnyK () -> Button) -> AnyK () -> Button
forall a b. (a -> b) -> a -> b
$ LayerTag -> m ()
forall (m :: * -> *). MonadKIO m => LayerTag -> m ()
shellCmd LayerTag
t

--------------------------------------------------------------------------------
-- $combinators
--
-- Functions that take 'Button's and combine them to form new 'Button's.

-- | Create a new button from 2 buttons, an inner and an outer. When the new
-- button is pressed, first the outer is pressed, then the inner. On release,
-- the inner is released first, and then the outer.
around ::
     Button -- ^ The outer 'Button'
  -> Button -- ^ The inner 'Button'
  -> Button -- ^ The resulting nested 'Button'
around :: Button -> Button -> Button
around outer :: Button
outer inner :: Button
inner = Action -> Action -> Button
Button
  (AnyK () -> Action
Action (Action -> AnyK ()
runAction (Button
outerButton -> Getting Action Button Action -> Action
forall s a. s -> Getting a s a -> a
^.Getting Action Button Action
forall c. HasButton c => Lens' c Action
pressAction)   m () -> m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Action -> AnyK ()
runAction (Button
innerButton -> Getting Action Button Action -> Action
forall s a. s -> Getting a s a -> a
^.Getting Action Button Action
forall c. HasButton c => Lens' c Action
pressAction)))
  (AnyK () -> Action
Action (Action -> AnyK ()
runAction (Button
innerButton -> Getting Action Button Action -> Action
forall s a. s -> Getting a s a -> a
^.Getting Action Button Action
forall c. HasButton c => Lens' c Action
releaseAction) m () -> m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Action -> AnyK ()
runAction (Button
outerButton -> Getting Action Button Action -> Action
forall s a. s -> Getting a s a -> a
^.Getting Action Button Action
forall c. HasButton c => Lens' c Action
releaseAction)))

-- | A 'Button' that, once pressed, will surround the next button with another.
--
-- Think of this as, essentially, a tappable mod. For example, an 'aroundNext
-- KeyCtrl' would, once tapped, then make the next keypress C-<whatever>.
aroundNext ::
     Button -- ^ The outer 'Button'
  -> Button -- ^ The resulting 'Button'
aroundNext :: Button -> Button
aroundNext b :: Button
b = AnyK () -> Button
onPress (AnyK () -> Button) -> AnyK () -> Button
forall a b. (a -> b) -> a -> b
$ KeyPred -> (KeyEvent -> m Catch) -> m ()
forall (m :: * -> *).
MonadKIO m =>
KeyPred -> (KeyEvent -> m Catch) -> m ()
await KeyPred
isPress ((KeyEvent -> m Catch) -> m ()) -> (KeyEvent -> m Catch) -> m ()
forall a b. (a -> b) -> a -> b
$ \e :: KeyEvent
e -> do
  Action -> m ()
Action -> AnyK ()
runAction (Action -> m ()) -> Action -> m ()
forall a b. (a -> b) -> a -> b
$ Button
bButton -> Getting Action Button Action -> Action
forall s a. s -> Getting a s a -> a
^.Getting Action Button Action
forall c. HasButton c => Lens' c Action
pressAction
  KeyPred -> (KeyEvent -> m Catch) -> m ()
forall (m :: * -> *).
MonadKIO m =>
KeyPred -> (KeyEvent -> m Catch) -> m ()
await (Keycode -> KeyPred
isReleaseOf (Keycode -> KeyPred) -> Keycode -> KeyPred
forall a b. (a -> b) -> a -> b
$ KeyEvent
eKeyEvent -> Getting Keycode KeyEvent Keycode -> Keycode
forall s a. s -> Getting a s a -> a
^.Getting Keycode KeyEvent Keycode
Lens' KeyEvent Keycode
keycode) ((KeyEvent -> m Catch) -> m ()) -> (KeyEvent -> m Catch) -> m ()
forall a b. (a -> b) -> a -> b
$ \_ -> do
    Action -> m ()
Action -> AnyK ()
runAction (Action -> m ()) -> Action -> m ()
forall a b. (a -> b) -> a -> b
$ Button
bButton -> Getting Action Button Action -> Action
forall s a. s -> Getting a s a -> a
^.Getting Action Button Action
forall c. HasButton c => Lens' c Action
releaseAction
    Catch -> m Catch
forall (f :: * -> *) a. Applicative f => a -> f a
pure Catch
NoCatch
  Catch -> m Catch
forall (f :: * -> *) a. Applicative f => a -> f a
pure Catch
NoCatch

-- | Create a new button that performs both a press and release of the input
-- button on just a press or release
tapOn ::
     Switch -- ^ Which 'Switch' should trigger the tap
  -> Button -- ^ The 'Button' to tap
  -> Button -- ^ The tapping 'Button'
tapOn :: Switch -> Button -> Button
tapOn Press   b :: Button
b = AnyK () -> AnyK () -> Button
mkButton (Button -> m ()
forall (m :: * -> *). MonadK m => Button -> m ()
tap Button
b)   (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
tapOn Release b :: Button
b = AnyK () -> AnyK () -> Button
mkButton (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (Button -> m ()
forall (m :: * -> *). MonadK m => Button -> m ()
tap Button
b)

-- | Create a 'Button' that performs a tap of one button if it is released
-- within an interval. If the interval is exceeded, press the other button (and
-- release it when a release is detected).
tapHold :: Milliseconds -> Button -> Button -> Button
tapHold :: Milliseconds -> Button -> Button -> Button
tapHold ms :: Milliseconds
ms t :: Button
t h :: Button
h = AnyK () -> Button
onPress (AnyK () -> Button) -> AnyK () -> Button
forall a b. (a -> b) -> a -> b
$ Milliseconds -> m KeyPred -> m () -> (Trigger -> m Catch) -> m ()
forall (m :: * -> *).
MonadK m =>
Milliseconds -> m KeyPred -> m () -> (Trigger -> m Catch) -> m ()
withinHeld Milliseconds
ms (Switch -> m KeyPred
forall (m :: * -> *). MonadK m => Switch -> m KeyPred
matchMy Switch
Release)
  (Button -> m ()
forall (m :: * -> *). MonadK m => Button -> m ()
press Button
h)                     -- If we catch timeout before release
  (m Catch -> Trigger -> m Catch
forall a b. a -> b -> a
const (m Catch -> Trigger -> m Catch) -> m Catch -> Trigger -> m Catch
forall a b. (a -> b) -> a -> b
$ Button -> m ()
forall (m :: * -> *). MonadK m => Button -> m ()
tap Button
t m () -> m Catch -> m Catch
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Catch -> m Catch
forall (f :: * -> *) a. Applicative f => a -> f a
pure Catch
Catch) -- If we catch release before timeout

-- | Create a 'Button' that performs a tap of 1 button if the next event is its
-- own release, or else switches to holding some other button if the next event
-- is a different keypress.
tapNext :: Button -> Button -> Button
tapNext :: Button -> Button -> Button
tapNext t :: Button
t h :: Button
h = AnyK () -> Button
onPress (AnyK () -> Button) -> AnyK () -> Button
forall a b. (a -> b) -> a -> b
$ HookLocation -> (KeyEvent -> m Catch) -> m ()
forall (m :: * -> *).
MonadKIO m =>
HookLocation -> (KeyEvent -> m Catch) -> m ()
hookF HookLocation
InputHook ((KeyEvent -> m Catch) -> m ()) -> (KeyEvent -> m Catch) -> m ()
forall a b. (a -> b) -> a -> b
$ \e :: KeyEvent
e -> do
  KeyPred
p <- Switch -> m KeyPred
forall (m :: * -> *). MonadK m => Switch -> m KeyPred
matchMy Switch
Release
  if KeyPred
p KeyEvent
e
    then Button -> m ()
forall (m :: * -> *). MonadK m => Button -> m ()
tap Button
t   m () -> m Catch -> m Catch
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Catch -> m Catch
forall (f :: * -> *) a. Applicative f => a -> f a
pure Catch
Catch
    else Button -> m ()
forall (m :: * -> *). MonadK m => Button -> m ()
press Button
h m () -> m Catch -> m Catch
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Catch -> m Catch
forall (f :: * -> *) a. Applicative f => a -> f a
pure Catch
NoCatch

-- | Like 'tapNext', except that after some interval it switches anyways
tapHoldNext :: Milliseconds -> Button -> Button -> Button
tapHoldNext :: Milliseconds -> Button -> Button -> Button
tapHoldNext ms :: Milliseconds
ms t :: Button
t h :: Button
h = AnyK () -> Button
onPress (AnyK () -> Button) -> AnyK () -> Button
forall a b. (a -> b) -> a -> b
$ Milliseconds -> m KeyPred -> m () -> (Trigger -> m Catch) -> m ()
forall (m :: * -> *).
MonadK m =>
Milliseconds -> m KeyPred -> m () -> (Trigger -> m Catch) -> m ()
within Milliseconds
ms (KeyPred -> m KeyPred
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyPred -> m KeyPred) -> KeyPred -> m KeyPred
forall a b. (a -> b) -> a -> b
$ Bool -> KeyPred
forall a b. a -> b -> a
const Bool
True) (Button -> m ()
forall (m :: * -> *). MonadK m => Button -> m ()
press Button
h) ((Trigger -> m Catch) -> m ()) -> (Trigger -> m Catch) -> m ()
forall a b. (a -> b) -> a -> b
$ \tr :: Trigger
tr -> do
  KeyPred
p <- Switch -> m KeyPred
forall (m :: * -> *). MonadK m => Switch -> m KeyPred
matchMy Switch
Release
  if KeyPred
p KeyPred -> KeyPred
forall a b. (a -> b) -> a -> b
$ Trigger
trTrigger -> Getting KeyEvent Trigger KeyEvent -> KeyEvent
forall s a. s -> Getting a s a -> a
^.Getting KeyEvent Trigger KeyEvent
forall c. HasTrigger c => Lens' c KeyEvent
event
    then Button -> m ()
forall (m :: * -> *). MonadK m => Button -> m ()
tap Button
t   m () -> m Catch -> m Catch
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Catch -> m Catch
forall (f :: * -> *) a. Applicative f => a -> f a
pure Catch
Catch
    else Button -> m ()
forall (m :: * -> *). MonadK m => Button -> m ()
press Button
h m () -> m Catch -> m Catch
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Catch -> m Catch
forall (f :: * -> *) a. Applicative f => a -> f a
pure Catch
NoCatch

-- | Create a tap-hold style button that makes its decision based on the next
-- detected release in the following manner:
-- 1. It is the release of this button: We are tapping
-- 2. It is of some other button that was pressed *before* this one, ignore.
-- 3. It is of some other button that was pressed *after* this one, we hold.
--
-- It does all of this while holding processing of other buttons, so time will
-- get rolled back like a TapHold button.
tapNextRelease :: Button -> Button -> Button
tapNextRelease :: Button -> Button -> Button
tapNextRelease t :: Button
t h :: Button
h = AnyK () -> Button
onPress (AnyK () -> Button) -> AnyK () -> Button
forall a b. (a -> b) -> a -> b
$ do
  Bool -> m ()
forall (m :: * -> *). MonadKIO m => Bool -> m ()
hold Bool
True
  [Keycode] -> m ()
forall (m :: * -> *). MonadK m => [Keycode] -> m ()
go []
  where
    go :: MonadK m => [Keycode] ->  m ()
    go :: [Keycode] -> m ()
go ks :: [Keycode]
ks = HookLocation -> (KeyEvent -> m Catch) -> m ()
forall (m :: * -> *).
MonadKIO m =>
HookLocation -> (KeyEvent -> m Catch) -> m ()
hookF HookLocation
InputHook ((KeyEvent -> m Catch) -> m ()) -> (KeyEvent -> m Catch) -> m ()
forall a b. (a -> b) -> a -> b
$ \e :: KeyEvent
e -> do
      KeyPred
p <- Switch -> m KeyPred
forall (m :: * -> *). MonadK m => Switch -> m KeyPred
matchMy Switch
Release
      let isRel :: Bool
isRel = KeyPred
isRelease KeyEvent
e
      if
        -- If the next event is my own release: we act as if we were tapped
        | KeyPred
p KeyEvent
e -> m Catch
forall (m :: * -> *). MonadK m => m Catch
doTap
        -- If the next event is the release of some button that was held after me
        -- we act as if we were held
        | Bool
isRel Bool -> Bool -> Bool
&& (KeyEvent
eKeyEvent -> Getting Keycode KeyEvent Keycode -> Keycode
forall s a. s -> Getting a s a -> a
^.Getting Keycode KeyEvent Keycode
Lens' KeyEvent Keycode
keycode Keycode -> [Keycode] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Keycode]
ks) -> KeyEvent -> m Catch
forall (m :: * -> *). MonadK m => KeyEvent -> m Catch
doHold KeyEvent
e
        -- Else, if it is a press, store the keycode and wait again
        | Bool -> Bool
not Bool
isRel                       -> [Keycode] -> m ()
forall (m :: * -> *). MonadK m => [Keycode] -> m ()
go ((KeyEvent
eKeyEvent -> Getting Keycode KeyEvent Keycode -> Keycode
forall s a. s -> Getting a s a -> a
^.Getting Keycode KeyEvent Keycode
Lens' KeyEvent Keycode
keycode)Keycode -> [Keycode] -> [Keycode]
forall a. a -> [a] -> [a]
:[Keycode]
ks) m () -> m Catch -> m Catch
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Catch -> m Catch
forall (f :: * -> *) a. Applicative f => a -> f a
pure Catch
NoCatch
        -- Else, if it is a release of some button held before me, just ignore
        | Bool
otherwise                       -> [Keycode] -> m ()
forall (m :: * -> *). MonadK m => [Keycode] -> m ()
go [Keycode]
ks m () -> m Catch -> m Catch
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Catch -> m Catch
forall (f :: * -> *) a. Applicative f => a -> f a
pure Catch
NoCatch

    -- Behave like a tap is simple: tap the button `t` and release processing
    doTap :: MonadK m => m Catch
    doTap :: m Catch
doTap = Button -> m ()
forall (m :: * -> *). MonadK m => Button -> m ()
tap Button
t m () -> m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Bool -> m ()
forall (m :: * -> *). MonadKIO m => Bool -> m ()
hold Bool
False m () -> m Catch -> m Catch
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Catch -> m Catch
forall (f :: * -> *) a. Applicative f => a -> f a
pure Catch
Catch

    -- Behave like a hold is not simple: first we release the processing hold,
    -- then we catch the release of ButtonX that triggered this action, and then
    -- we rethrow this release.
    doHold :: MonadK m => KeyEvent -> m Catch
    doHold :: KeyEvent -> m Catch
doHold e :: KeyEvent
e = Button -> m ()
forall (m :: * -> *). MonadK m => Button -> m ()
press Button
h m () -> m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Bool -> m ()
forall (m :: * -> *). MonadKIO m => Bool -> m ()
hold Bool
False m () -> m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> KeyEvent -> m ()
forall (m :: * -> *). MonadKIO m => KeyEvent -> m ()
inject KeyEvent
e m () -> m Catch -> m Catch
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Catch -> m Catch
forall (f :: * -> *) a. Applicative f => a -> f a
pure Catch
Catch


-- | Create a tap-hold style button that makes its decision based on the next
-- detected release in the following manner:
-- 1. It is the release of this button: We are tapping
-- 2. It is of some other button that was pressed *before* this one, ignore.
-- 3. It is of some other button that was pressed *after* this one, we hold.
--
-- If we encounter the timeout before any other release, we switch to holding
-- mode.
--
-- It does all of this while holding processing of other buttons, so time will
-- get rolled back like a TapHold button.
tapHoldNextRelease :: Milliseconds -> Button -> Button -> Button
tapHoldNextRelease :: Milliseconds -> Button -> Button -> Button
tapHoldNextRelease ms :: Milliseconds
ms t :: Button
t h :: Button
h = AnyK () -> Button
onPress (AnyK () -> Button) -> AnyK () -> Button
forall a b. (a -> b) -> a -> b
$ do
  Bool -> m ()
forall (m :: * -> *). MonadKIO m => Bool -> m ()
hold Bool
True
  Milliseconds -> [Keycode] -> m ()
forall (m :: * -> *). MonadK m => Milliseconds -> [Keycode] -> m ()
go Milliseconds
ms []
  where

    go :: MonadK m => Milliseconds -> [Keycode] ->  m ()
    go :: Milliseconds -> [Keycode] -> m ()
go ms' :: Milliseconds
ms' ks :: [Keycode]
ks = HookLocation
-> Milliseconds -> m () -> (Trigger -> m Catch) -> m ()
forall (m :: * -> *).
MonadK m =>
HookLocation
-> Milliseconds -> m () -> (Trigger -> m Catch) -> m ()
tHookF HookLocation
InputHook Milliseconds
ms' m ()
AnyK ()
onTimeout ((Trigger -> m Catch) -> m ()) -> (Trigger -> m Catch) -> m ()
forall a b. (a -> b) -> a -> b
$ \r :: Trigger
r -> do
      KeyPred
p <- Switch -> m KeyPred
forall (m :: * -> *). MonadK m => Switch -> m KeyPred
matchMy Switch
Release
      let e :: KeyEvent
e = Trigger
rTrigger -> Getting KeyEvent Trigger KeyEvent -> KeyEvent
forall s a. s -> Getting a s a -> a
^.Getting KeyEvent Trigger KeyEvent
forall c. HasTrigger c => Lens' c KeyEvent
event
      let isRel :: Bool
isRel = KeyPred
isRelease KeyEvent
e
      if
        -- If the next event is my own release: act like tapped
        | KeyPred
p KeyEvent
e -> m Catch
forall (m :: * -> *). MonadK m => m Catch
onRelSelf
        -- If the next event is another release that was pressed after me
        | Bool
isRel Bool -> Bool -> Bool
&& (KeyEvent
eKeyEvent -> Getting Keycode KeyEvent Keycode -> Keycode
forall s a. s -> Getting a s a -> a
^.Getting Keycode KeyEvent Keycode
Lens' KeyEvent Keycode
keycode Keycode -> [Keycode] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Keycode]
ks) -> KeyEvent -> m Catch
forall (m :: * -> *). MonadK m => KeyEvent -> m Catch
onRelOther KeyEvent
e
        -- If the next event is a press, store and recurse
        | Bool -> Bool
not Bool
isRel -> Milliseconds -> [Keycode] -> m ()
forall (m :: * -> *). MonadK m => Milliseconds -> [Keycode] -> m ()
go (Milliseconds
ms' Milliseconds -> Milliseconds -> Milliseconds
forall a. Num a => a -> a -> a
- Trigger
rTrigger
-> Getting Milliseconds Trigger Milliseconds -> Milliseconds
forall s a. s -> Getting a s a -> a
^.Getting Milliseconds Trigger Milliseconds
forall c. HasTrigger c => Lens' c Milliseconds
elapsed) (KeyEvent
eKeyEvent -> Getting Keycode KeyEvent Keycode -> Keycode
forall s a. s -> Getting a s a -> a
^.Getting Keycode KeyEvent Keycode
Lens' KeyEvent Keycode
keycode Keycode -> [Keycode] -> [Keycode]
forall a. a -> [a] -> [a]
: [Keycode]
ks) m () -> m Catch -> m Catch
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Catch -> m Catch
forall (f :: * -> *) a. Applicative f => a -> f a
pure Catch
NoCatch
        -- If the next event is a release of some button pressed before me, recurse
        | Bool
otherwise -> Milliseconds -> [Keycode] -> m ()
forall (m :: * -> *). MonadK m => Milliseconds -> [Keycode] -> m ()
go (Milliseconds
ms' Milliseconds -> Milliseconds -> Milliseconds
forall a. Num a => a -> a -> a
- Trigger
rTrigger
-> Getting Milliseconds Trigger Milliseconds -> Milliseconds
forall s a. s -> Getting a s a -> a
^.Getting Milliseconds Trigger Milliseconds
forall c. HasTrigger c => Lens' c Milliseconds
elapsed) [Keycode]
ks m () -> m Catch -> m Catch
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Catch -> m Catch
forall (f :: * -> *) a. Applicative f => a -> f a
pure Catch
NoCatch

    onTimeout :: MonadK m =>  m ()
    onTimeout :: m ()
onTimeout = Button -> m ()
forall (m :: * -> *). MonadK m => Button -> m ()
press Button
h m () -> m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Bool -> m ()
forall (m :: * -> *). MonadKIO m => Bool -> m ()
hold Bool
False

    onRelSelf :: MonadK m => m Catch
    onRelSelf :: m Catch
onRelSelf = Button -> m ()
forall (m :: * -> *). MonadK m => Button -> m ()
tap Button
t m () -> m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Bool -> m ()
forall (m :: * -> *). MonadKIO m => Bool -> m ()
hold Bool
False m () -> m Catch -> m Catch
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Catch -> m Catch
forall (f :: * -> *) a. Applicative f => a -> f a
pure Catch
Catch

    onRelOther :: MonadK m => KeyEvent -> m Catch
    onRelOther :: KeyEvent -> m Catch
onRelOther e :: KeyEvent
e = Button -> m ()
forall (m :: * -> *). MonadK m => Button -> m ()
press Button
h m () -> m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Bool -> m ()
forall (m :: * -> *). MonadKIO m => Bool -> m ()
hold Bool
False m () -> m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> KeyEvent -> m ()
forall (m :: * -> *). MonadKIO m => KeyEvent -> m ()
inject KeyEvent
e m () -> m Catch -> m Catch
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Catch -> m Catch
forall (f :: * -> *) a. Applicative f => a -> f a
pure Catch
Catch


-- | Create a 'Button' that contains a number of delays and 'Button's. As long
-- as the next press is registered before the timeout, the multiTap descends
-- into its list. The moment a delay is exceeded or immediately upon reaching
-- the last button, that button is pressed.
multiTap :: Button -> [(Milliseconds, Button)] -> Button
multiTap :: Button -> [(Milliseconds, Button)] -> Button
multiTap l :: Button
l bs :: [(Milliseconds, Button)]
bs = AnyK () -> Button
onPress (AnyK () -> Button) -> AnyK () -> Button
forall a b. (a -> b) -> a -> b
$ [(Milliseconds, Button)] -> AnyK ()
go [(Milliseconds, Button)]
bs
  where
    go :: [(Milliseconds, Button)] -> AnyK ()
    go :: [(Milliseconds, Button)] -> AnyK ()
go []            = Button -> m ()
forall (m :: * -> *). MonadK m => Button -> m ()
press Button
l
    go ((ms :: Milliseconds
ms, b :: Button
b):bs' :: [(Milliseconds, Button)]
bs') = do
      -- This is a bit complicated. What we do is:
      -- 1.  We wait for the release of the key that triggered this action
      -- 2A. If it doesn't occur in the interval we press the button from the list
      --     and we are done.
      -- 2B. If we do detect the release, we must now keep waiting to detect another press.
      -- 3A. If we do not detect a press before the interval is up, we know a tap occured,
      --     so we tap the current button and we are done.
      -- 3B. If we detect another press, then the user is descending into the buttons tied
      --     to this multi-tap, so we recurse on the remaining buttons.
      let onMatch :: Trigger -> m Catch
onMatch t :: Trigger
t = do
            Milliseconds -> m KeyPred -> m () -> (Trigger -> m Catch) -> m ()
forall (m :: * -> *).
MonadK m =>
Milliseconds -> m KeyPred -> m () -> (Trigger -> m Catch) -> m ()
within (Milliseconds
ms Milliseconds -> Milliseconds -> Milliseconds
forall a. Num a => a -> a -> a
- Trigger
tTrigger
-> Getting Milliseconds Trigger Milliseconds -> Milliseconds
forall s a. s -> Getting a s a -> a
^.Getting Milliseconds Trigger Milliseconds
forall c. HasTrigger c => Lens' c Milliseconds
elapsed) (Switch -> m KeyPred
forall (m :: * -> *). MonadK m => Switch -> m KeyPred
matchMy Switch
Press)
                   (Button -> m ()
forall (m :: * -> *). MonadK m => Button -> m ()
tap Button
b)
                   (m Catch -> Trigger -> m Catch
forall a b. a -> b -> a
const (m Catch -> Trigger -> m Catch) -> m Catch -> Trigger -> m Catch
forall a b. (a -> b) -> a -> b
$ [(Milliseconds, Button)] -> AnyK ()
go [(Milliseconds, Button)]
bs' m () -> m Catch -> m Catch
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Catch -> m Catch
forall (f :: * -> *) a. Applicative f => a -> f a
pure Catch
Catch)
            Catch -> m Catch
forall (f :: * -> *) a. Applicative f => a -> f a
pure Catch
Catch
      Milliseconds -> m KeyPred -> m () -> (Trigger -> m Catch) -> m ()
forall (m :: * -> *).
MonadK m =>
Milliseconds -> m KeyPred -> m () -> (Trigger -> m Catch) -> m ()
within Milliseconds
ms (Switch -> m KeyPred
forall (m :: * -> *). MonadK m => Switch -> m KeyPred
matchMy Switch
Release) (Button -> m ()
forall (m :: * -> *). MonadK m => Button -> m ()
press Button
b) Trigger -> m Catch
onMatch


-- | Create a 'Button' that performs a series of taps on press. Note that the
-- last button is only released when the tapMacro itself is released.
tapMacro :: [Button] -> Button
tapMacro :: [Button] -> Button
tapMacro bs :: [Button]
bs = AnyK () -> Button
onPress (AnyK () -> Button) -> AnyK () -> Button
forall a b. (a -> b) -> a -> b
$ [Button] -> m ()
forall (f :: * -> *). MonadK f => [Button] -> f ()
go [Button]
bs
  where
    go :: [Button] -> f ()
go []      = () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    go (b :: Button
b:[])  = Button -> f ()
forall (m :: * -> *). MonadK m => Button -> m ()
press Button
b
    go (b :: Button
b:rst :: [Button]
rst) = Button -> f ()
forall (m :: * -> *). MonadK m => Button -> m ()
tap Button
b f () -> f () -> f ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Button] -> f ()
go [Button]
rst


-- | Switch to a layer for a period of time, then automatically switch back
layerDelay :: Milliseconds -> LayerTag -> Button
layerDelay :: Milliseconds -> LayerTag -> Button
layerDelay d :: Milliseconds
d t :: LayerTag
t = AnyK () -> Button
onPress (AnyK () -> Button) -> AnyK () -> Button
forall a b. (a -> b) -> a -> b
$ do
  LayerOp -> m ()
forall (m :: * -> *). MonadKIO m => LayerOp -> m ()
layerOp (LayerTag -> LayerOp
PushLayer LayerTag
t)
  Milliseconds -> m () -> m ()
forall (m :: * -> *). MonadK m => Milliseconds -> m () -> m ()
after Milliseconds
d (LayerOp -> m ()
forall (m :: * -> *). MonadKIO m => LayerOp -> m ()
layerOp (LayerOp -> m ()) -> LayerOp -> m ()
forall a b. (a -> b) -> a -> b
$ LayerTag -> LayerOp
PopLayer LayerTag
t)

-- | Switch to a layer for the next button-press and switch back automaically.
--
-- NOTE: liable to change, this is essentially just `aroundNext` and
-- `layerToggle` combined.
layerNext :: LayerTag -> Button
layerNext :: LayerTag -> Button
layerNext t :: LayerTag
t = AnyK () -> Button
onPress (AnyK () -> Button) -> AnyK () -> Button
forall a b. (a -> b) -> a -> b
$ do
  LayerOp -> m ()
forall (m :: * -> *). MonadKIO m => LayerOp -> m ()
layerOp (LayerTag -> LayerOp
PushLayer LayerTag
t)
  KeyPred -> (KeyEvent -> m Catch) -> m ()
forall (m :: * -> *).
MonadKIO m =>
KeyPred -> (KeyEvent -> m Catch) -> m ()
await KeyPred
isPress (\_ -> m () -> m ()
forall (m :: * -> *). MonadK m => m () -> m ()
whenDone (LayerOp -> m ()
forall (m :: * -> *). MonadKIO m => LayerOp -> m ()
layerOp (LayerOp -> m ()) -> LayerOp -> m ()
forall a b. (a -> b) -> a -> b
$ LayerTag -> LayerOp
PopLayer LayerTag
t) m () -> m Catch -> m Catch
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Catch -> m Catch
forall (f :: * -> *) a. Applicative f => a -> f a
pure Catch
NoCatch)