Button.hs

{-|
Module      : KMonad.Model.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.Model.Button
  ( -- * Button basics
    -- $but
    Button
  , HasButton(..)
  , onPress
  , onRelease
  , mkButton
  , around
  , tapOn

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

  -- * Button combinators
  -- $combinators
  , aroundNext
  , aroundNextTimeout
  , aroundNextSingle
  , beforeAfterNext
  , layerDelay
  , layerNext
  , tapHold
  , multiTap
  , tapNext
  , tapHoldNext
  , tapNextRelease
  , tapHoldNextRelease
  , tapNextPress
  , tapMacro
  , tapMacroRelease
  , stickyKey
  )
where

import KMonad.Prelude

import KMonad.Model.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
  { _pressAction   :: !Action -- ^ Action to take when pressed
  , _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 a b = Button (Action a) (Action b)

-- | Create a new button with only a 'Press' action
onPress :: AnyK () -> Button
onPress p = mkButton p $ pure ()

onRelease :: AnyK () -> Button
onRelease = mkButton (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 b = do
  runAction $ b^.pressAction
  runAction $ b^.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 b = do
  runAction $ b^.pressAction
  awaitMy Release $ do
    runAction $ b^.releaseAction
    pure 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 c = mkButton
  (emit $ mkPress c)
  (emit $ mkRelease c)

-- | A button that emits only a Press of a keycode.
pressOnly :: Keycode -> Button
pressOnly c = onPress $ emit $ mkPress c

-- | A button that emits only a Release of a keycode.
releaseOnly :: Keycode -> Button
releaseOnly c = onPress $ emit $ mkRelease 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 modder = around (emitB modder)

-- | Create a button that toggles a layer on and off
layerToggle :: LayerTag -> Button
layerToggle t = mkButton
  (layerOp $ PushLayer t)
  (layerOp $ PopLayer  t)

-- | Create a button that switches the base-layer on a press
layerSwitch :: LayerTag -> Button
layerSwitch t = onPress (layerOp $ SetBaseLayer t)

-- | Create a button that adds a layer on a press
layerAdd :: LayerTag -> Button
layerAdd t = onPress (layerOp $ PushLayer t)

-- | Create a button that removes the top instance of a layer on a press
layerRem :: LayerTag -> Button
layerRem t = onPress (layerOp $ PopLayer t)

-- | Create a button that does nothing (but captures the input)
pass :: Button
pass = onPress $ pure ()

-- | Create a button that executes a shell command on press and possibly on
-- release
cmdButton :: Text -> Maybe Text -> Button
cmdButton pr mbR = mkButton (shellCmd pr) (maybe (pure ()) shellCmd mbR)

--------------------------------------------------------------------------------
-- $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 outer inner = Button
  (Action (runAction (outer^.pressAction)   *> runAction (inner^.pressAction)))
  (Action (runAction (inner^.releaseAction) *> runAction (outer^.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 b = onPress $ await isPress $ \e -> do
  runAction $ b^.pressAction
  await (isReleaseOf $ e^.keycode) $ \_ -> do
    runAction $ b^.releaseAction
    pure NoCatch
  pure NoCatch

-- | A 'Button' that, once pressed, will surround the next button within some timeout with another.
--
-- If some other key is not pressed within an interval another button will be triggered as a tap.
aroundNextTimeout ::
     Milliseconds -- ^ How long before we tap
  -> Button       -- ^ The 'Button' to use to surround next
  -> Button       -- ^ The 'Button' to tap on timeout
  -> Button       -- ^ The resulting button
aroundNextTimeout d b t = onPress $ within d (pure isPress) (tap t) $ \trig -> do
  runAction $ b^.pressAction
  await (isReleaseOf $ trig^.event.keycode) $ \_ -> do
    runAction $ b^.releaseAction
    pure NoCatch
  pure NoCatch

-- | 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>.
--
-- This differs from 'aroundNext' in that it explicitly releases the modifier
-- immediately after the first event, where `aroundSingle` waits around for the
-- original key that was modified to be released itself.
aroundNextSingle ::
     Button -- ^ The outer 'Button'
  -> Button -- ^ The resulting 'Button'
aroundNextSingle b = onPress $ await isPress $ \_ -> do
  runAction $ b^.pressAction
  -- Wait for the next *event*, regardless of what it is
  await (pure True) $ \_ -> do
    runAction $ b^.releaseAction
    pure NoCatch
  pure 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 Press   b = mkButton (tap b)   (pure ())
tapOn Release b = mkButton (pure ()) (tap 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 ms t h = onPress $ withinHeld ms (matchMy Release)
  (press h)                     -- If we catch timeout before release
  (const $ tap t $> 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 t h = onPress $ hookF InputHook $ \e -> do
  p <- matchMy Release
  if p e
    then tap t   $> Catch
    else press h $> NoCatch

-- | Like 'tapNext', except that after some interval it switches anyways
tapHoldNext :: Milliseconds -> Button -> Button -> Maybe Button -> Button
tapHoldNext ms t h mtb = onPress $ within ms (pure $ const True) onTimeout $ \tr -> do
  p <- matchMy Release
  if p $ tr^.event
    then tap t   $> Catch
    else press h $> NoCatch
  where
    onTimeout :: MonadK m =>  m ()
    onTimeout = press $ fromMaybe h mtb

-- | Surround some future button with a before and after tap
beforeAfterNext :: Button -> Button -> Button
beforeAfterNext b a = onPress $ do
  tap b
  await isPress $ \e -> do
    await (isReleaseOf $ e^.keycode) $ \_ -> do
      tap a
      pure NoCatch
    pure 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 t h = onPress $ do
  hold True
  go []
  where
    go :: MonadK m => [Keycode] ->  m ()
    go ks = hookF InputHook $ \e -> do
      p <- matchMy Release
      let isRel = isRelease e
      if
        -- If the next event is my own release: we act as if we were tapped
        | p e -> doTap
        -- If the next event is the release of some button that was held after me
        -- we act as if we were held
        | isRel && (e^.keycode `elem` ks) -> doHold e
        -- Else, if it is a press, store the keycode and wait again
        | not isRel                       -> go ((e^.keycode):ks) $> NoCatch
        -- Else, if it is a release of some button held before me, just ignore
        | otherwise                       -> go ks $> NoCatch

    -- Behave like a tap is simple: tap the button `t` and release processing
    doTap :: MonadK m => m Catch
    doTap = tap t *> hold False $> 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 e = press h *> hold False *> inject e $> 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 the
-- specified timeout button, or to the hold button if none is specified.
--
-- 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 -> Maybe Button -> Button
tapHoldNextRelease ms t h mtb = onPress $ do
  hold True
  go ms []
  where

    go :: MonadK m => Milliseconds -> [Keycode] ->  m ()
    go ms' ks = tHookF InputHook ms' onTimeout $ \r -> do
      p <- matchMy Release
      let e = r^.event
      let isRel = isRelease e
      if
        -- If the next event is my own release: act like tapped
        | p e -> onRelSelf
        -- If the next event is another release that was pressed after me
        | isRel && (e^.keycode `elem` ks) -> onRelOther e
        -- If the next event is a press, store and recurse
        | not isRel -> go (ms' - r^.elapsed) (e^.keycode : ks) $> NoCatch
        -- If the next event is a release of some button pressed before me, recurse
        | otherwise -> go (ms' - r^.elapsed) ks $> NoCatch

    onTimeout :: MonadK m =>  m ()
    onTimeout = press (fromMaybe h mtb) *> hold False

    onRelSelf :: MonadK m => m Catch
    onRelSelf = tap t *> hold False $> Catch

    onRelOther :: MonadK m => KeyEvent -> m Catch
    onRelOther e = press h *> hold False *> inject e $> Catch

-- | Create a button just like tap-release, but also trigger a hold on presses:
-- 1. It is the release of this button: We are tapping
-- 2. It is the press of some other button, we hold
-- 3. It is the release of some other button, ignore.
tapNextPress :: Button -> Button -> Button
tapNextPress t h = onPress go
  where
    go :: MonadK m => m ()
    go = hookF InputHook $ \e -> do
      p <- matchMy Release
      if
        -- If the next event is my own release: we act as if we were tapped
        | p e -> doTap
        -- If the next event is a press: we act as if we were held
        | isPress e -> doHold e
        -- Else, if it is a release of some other button, just ignore
        | otherwise -> go $> NoCatch

    -- Behave like a tap
    doTap :: MonadK m => m Catch
    doTap = tap t $> Catch

    -- Behave like a hold:
    -- We catch the event of ButtonX that triggered this action, and then
    -- we rethrow this event after holding.
    doHold :: MonadK m => KeyEvent -> m Catch
    doHold e = press h *> inject e $> 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 l bs = onPress $ go bs
  where
    go :: [(Milliseconds, Button)] -> AnyK ()
    go []            = press l
    go ((ms, b):bs') = do
      -- This is a bit complicated. What we do is:
      -- 1.  We wait for an event
      -- 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 of the key that triggered this action,
      --     we must now keep waiting to detect another press.
      -- 2C. If we detect another (unrelated) press event we cancel the
      --     remaining of the multi-tap sequence and trigger a tap on the
      --     current button of the sequence.
      -- 3A. After 2B, if we do not detect a press before the interval is up,
      --     we know a tap occurred, so we tap the current button and we are
      --     done.
      -- 3B. If we detect another press of the same key, then the user is
      --     descending into the buttons tied to this multi-tap, so we recurse
      --     on the remaining buttons.
      -- 3C. If we detect any other (unrelated) press event, then the multi-tap
      --     sequence is cancelled like in 2C. We trigger a tap of the current
      --     button of the sequence.
      let doNext pred onTimeout next ms = tHookF InputHook ms onTimeout $ \t -> do
            pr <- pred
            if | pr (t^.event)      -> next (ms - t^.elapsed) $> Catch
               | isPress (t^.event) -> tap b                  $> NoCatch
               | otherwise          -> pure NoCatch
      doNext (matchMy Release)
             (press b)
             (doNext (matchMy Press) (tap b) (\_ -> go bs'))
             ms

-- | 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 bs = onPress $ go bs
  where
    go []      = pure ()
    go [b]     = press b
    go (b:rst) = tap b >> go rst

-- | Create a 'Button' that performs a series of taps on press,
-- except for the last Button, which is tapped on release.
tapMacroRelease :: [Button] -> Button
tapMacroRelease bs = onPress $ go bs
  where
    go []      = pure ()
    go [b]     = awaitMy Release $ tap b >> pure Catch
    go (b:rst) = tap b >> go rst

-- | Switch to a layer for a period of time, then automatically switch back
layerDelay :: Milliseconds -> LayerTag -> Button
layerDelay d t = onPress $ do
  layerOp (PushLayer t)
  after d (layerOp $ PopLayer 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 t = onPress $ do
  layerOp (PushLayer t)
  await isPress (\_ -> whenDone (layerOp $ PopLayer t) $> NoCatch)

-- | Make a button into a sticky-key, i.e. a key that acts like it is
-- pressed for the button after it if that button was pressed in the
-- given timeframe.
stickyKey :: Milliseconds -> Button -> Button
stickyKey ms b = onPress go
 where
  go :: MonadK m => m ()
  go = hookF InputHook $ \e -> do
    p <- matchMy Release
    if | p e               -> doTap    $> Catch
         -- My own release; we act as if we were tapped
       | not (isRelease e) -> doHold e $> Catch
         -- The press of another button; act like we are held down
       | otherwise         -> go       $> NoCatch
         -- The release of some other button; ignore these

  doHold :: MonadK m => KeyEvent -> m ()
  doHold e = press b *> inject e

  doTap :: MonadK m => m ()
  doTap =
    within ms
           (pure isPress)  -- presses definitely happen after us
           (pure ())
           (\t -> runAction (b^.pressAction)
               *> inject (t^.event)
               *> after 3 (runAction $ b^.releaseAction)
               $> Catch)