path: root/src/Wetterhorn/Core/Keys.hs

module Wetterhorn.Core.Keys
  ( forwardKey,
    forwardEvent,
    KeysM,
    bind,
    subbind,
    subbind_,
    (.+),
    Modifier (..),
    keys,
    ignoreReleaseEvents,
    weak,
    continue,
    WeakKeyMatcher,
    nextKeyEvent,
    nextKeyPress,
    keysWithHandler,
    putKeyHandler,
    KeyHandler,
  )
where

import Control.Monad (void, when)
import Control.Monad.Fix (fix)
import Control.Monad.IO.Class
import Control.Monad.Reader.Class
import Control.Monad.State (MonadState (get, put))
import Data.Bits
import Data.Word
import Wetterhorn.Core.KeyEvent
import qualified Wetterhorn.Core.KeyEvent as KeyEvent
import Wetterhorn.Core.W
import Wetterhorn.Foreign.WlRoots (wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard)

-- | Forwards the given key event to the focused window.
forwardKey :: KeyEvent -> W ()
forwardKey keyEvent = do
  seatPtr <- getSeat
  wio $ do
    wlrSeatSetKeyboard
      seatPtr
      (device keyEvent)

    wlrSeatKeyboardNotifyKey
      seatPtr
      (timeMs keyEvent)
      (keycode keyEvent)
      ( case state keyEvent of
          KeyReleased -> 0
          _ -> 1
      )

-- | Forwards the current key event to the focused window.
forwardEvent :: KeysM ()
forwardEvent = liftW . forwardKey =<< ask

-- | Enumeration of possible modifiers
data Modifier = Shift | Lock | Control | Mod1 | Mod2 | Mod3 | Mod4 | Mod5
  deriving (Eq, Ord, Show, Read, Enum, Bounded)

-- | Converts a modifier to its associated mask.
modifierToMask :: Modifier -> Word32
modifierToMask m =
  1
    `shiftL` case m of
      Shift -> 0
      Lock -> 1
      Control -> 2
      Mod1 -> 3
      Mod2 -> 4
      Mod3 -> 5
      Mod4 -> 6
      Mod5 -> 7

-- | The Keys monad. This monad abstracts away control flow for handling key
-- bindings. This makes it easy to make key-sequence bindings.
newtype KeysM a = KeysM ((KeyEvent -> W ()) -> KeyEvent -> W (KeysMR a))

type KeyHandler = KeyEvent -> W ()

-- Return type in the keysM monad.
data KeysMR a = NextKey (KeysM a) | Lift a | Continue

keysWithHandler :: (KeyHandler -> W ()) -> KeysM a -> KeyHandler
keysWithHandler nextAction keysM = fix $ \top ke -> keys' top keysM ke
  where
    keys' top (KeysM fn) ke = do
      e <- fn top ke
      case e of
        NextKey keysM' -> nextAction (keys' top keysM')
        Lift _ -> return ()
        _ -> nextAction top

keys :: KeysM a -> KeyEvent -> W ()
keys = keysWithHandler putKeyHandler

putKeyHandler :: KeyHandler -> W ()
putKeyHandler handler = do
  s@State {currentHooks = hooks} <- get
  put
    s
      { currentHooks =
          hooks
            { keyHook = void <$> handler
            }
      }

-- | Returns the next key event. This returns both key pressed and key released
-- events, so it's good to be careful because duplicate casess can happen.
nextKeyEvent :: KeysM KeyEvent
nextKeyEvent = KeysM (\_ _ -> return (NextKey (KeysM (\_ -> return . Lift))))

-- | Returns the next KeyPressed event. This is likely what 90% of use cases
-- want rather than nextKeyEvent.
nextKeyPress :: KeysM KeyEvent
nextKeyPress = do
  k <- nextKeyEvent
  if KeyEvent.state k /= KeyPressed
    then forwardEvent >> nextKeyPress
    else return k

-- | Resets the handling of KeyBindings to the top. Operates like a 'continue'
-- statement in imperative programming languages.
continue :: KeysM ()
continue = KeysM $ \_ _ -> return Continue

instance Functor KeysM where
  fmap f (KeysM fn) = KeysM $ \top keyEvent -> do
    e <- fn top keyEvent
    return $
      case e of
        NextKey ma -> NextKey $ fmap f ma
        Lift a -> Lift $ f a
        Continue -> Continue

instance Applicative KeysM where
  pure a = KeysM (\_ _ -> return (Lift a))
  (<*>) mfn ma = do
    fn <- mfn
    fn <$> ma

instance Monad KeysM where
  a >>= fmb = keysJoin (fmap fmb a)
    where
      keysJoin (KeysM f) = KeysM $ \top keyEvent -> do
        e <- f top keyEvent
        case e of
          Lift (KeysM f') -> f' top keyEvent
          NextKey sub -> return $ NextKey $ keysJoin sub
          Continue -> return Continue

-- | KeysM can be lifted from a W action.
instance Wlike KeysM where
  liftW act = KeysM (\_ _ -> Lift <$> act)

-- | KeyM can be lifted from an IO action.
instance MonadIO KeysM where
  liftIO = liftW . wio

-- | Monad
instance MonadReader KeyEvent KeysM where
  ask = KeysM (\_ -> return . Lift)
  local fn (KeysM fn') = KeysM $ \a (fn -> ns) -> fn' a ns

--
-- binding EDSL used to expressively create key bindings and subbindings inside
-- a KeysM () context.
--

data KeyMatcher = KeyMatcher Word32 Char
  deriving (Show)

-- | Like a KeyMatcher, but allows additional modifiers to be pressed, not just
-- the exact ones given.
newtype WeakKeyMatcher = WeakKeyMatcher KeyMatcher

-- | Converts a KeyMatcher to a weak key matcher.
weak :: KeyMatcher -> WeakKeyMatcher
weak = WeakKeyMatcher

class KeyMatcherId r where
  toKeyMatcher :: r -> KeyMatcher

instance KeyMatcherId KeyMatcher where
  toKeyMatcher = id

instance KeyMatcherId Char where
  toKeyMatcher = KeyMatcher 0

class KeyMatcherBuilder b where
  (.+) :: (KeyMatcherId i) => b -> i -> KeyMatcher

instance KeyMatcherBuilder Modifier where
  (.+) m (toKeyMatcher -> (KeyMatcher mods ch)) =
    KeyMatcher (mods .|. modifierToMask m) ch

infixr 9 .+

class MatchKey m where
  matchKey :: m -> KeyEvent -> Bool

instance MatchKey (KeyEvent -> Bool) where
  matchKey = ($)

instance MatchKey Bool where
  matchKey = const

instance MatchKey Char where
  matchKey ch ev = ch == KeyEvent.codepoint ev

instance MatchKey KeyMatcher where
  matchKey (KeyMatcher m ch) ev =
    ch == KeyEvent.codepoint ev && m == KeyEvent.modifiers ev

instance MatchKey WeakKeyMatcher where
  matchKey (WeakKeyMatcher (KeyMatcher m ch)) ev =
    ch == KeyEvent.codepoint ev && (m .|. ms) == ms
    where
      ms = KeyEvent.modifiers ev

subbind :: (MatchKey m) => m -> KeysM () -> KeysM ()
subbind m act = do
  ev <- ask
  when (matchKey m ev) $ do
    _ <- nextKeyPress
    act
    continue

-- | Like 'subbind', but does not read the next keypress.
subbind_ :: (MatchKey m) => m -> KeysM () -> KeysM ()
subbind_ m act = do
  ev <- ask
  when (matchKey m ev) $ do
    act
    continue

bind :: (MatchKey m) => m -> W () -> KeysM ()
bind m act = do
  ev <- ask
  when (matchKey m ev) $ do
    liftW act
    continue

ignoreReleaseEvents :: KeysM ()
ignoreReleaseEvents = do
  ev <- ask
  when (KeyEvent.state ev /= KeyEvent.KeyPressed) $ do
    forwardEvent
    continue