path: root/src/Wetterhorn/Dsl/Input.hs

{-# LANGUAGE DataKinds #-}

module Wetterhorn.Dsl.Input
  ( InputM,
    InputEvent (..),
    InputProxy (..),
    NoProxy,
    withProxies,
    forwardEvent,
    forwardKey,
    whenKeyEvent,
    whenButtonEvent,
    useInputHandler,
    unwrap,
    filterEvent,
    isPressEvent,
    nextInputEventThat,
    replayEvents,
    isKeyEvent,
    nextInputPressEvent,
    continue,
    nextInputEvent,
    getModifierState,
  )
where

import Control.Concurrent (threadDelay)
import Control.Monad
import Control.Monad.Cont (MonadCont)
import Control.Monad.Loops (andM)
import Control.Monad.RWS
  ( MonadIO (liftIO),
    MonadReader (ask),
    MonadState (get),
    MonadTrans (lift),
    RWST,
    execRWST,
    gets,
    modify,
  )
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Maybe (MaybeT (runMaybeT))
import Data.IORef (newIORef, readIORef, writeIORef)
import Data.Proxy
import Data.Word (Word32)
import qualified Wetterhorn.Core.ButtonEvent as ButtonEvent
import qualified Wetterhorn.Core.KeyEvent as KeyEvent
import Wetterhorn.Core.W (W (..))
import qualified Wetterhorn.Core.W as W
import Wetterhorn.Foreign.WlRoots (guardNull, wlrKeyboardGetModifiers, wlrSeatGetKeyboard, wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard)

class InputProxy (spy :: k) where
  onKeyEvent :: Proxy spy -> InputEvent -> MaybeT W InputEvent

instance (InputProxy h, InputProxy t) => InputProxy (h ': t) where
  onKeyEvent _ = onKeyEvent (Proxy :: Proxy h) <=< onKeyEvent (Proxy :: Proxy t)

instance InputProxy '[] where
  onKeyEvent _ = return

data NoProxy

instance InputProxy NoProxy where
  onKeyEvent _ = return

instance (InputProxy s1, InputProxy s2) => InputProxy (s1, s2) where
  onKeyEvent proxy = onKeyEvent (fmap fst proxy) <=< onKeyEvent (fmap snd proxy)

-- | Union of event types.
data InputEvent
  = InputButtonEvent ButtonEvent.ButtonEvent
  | InputKeyEvent KeyEvent.KeyEvent

-- | Context for the input.
newtype InputContext spy = InputContext
  { -- | Top of the input routine. Used in "continue" statement.
    inputTop :: InputM spy ()
  }

newtype InputState spy = InputState
  { inputSource :: InputM spy InputEvent
  }

-- | Input monad for handling all kinds of input.
newtype InputM spy a = InputM (ContT () (RWST (InputContext spy) () (InputState spy) W) a)
  deriving (Monad, Functor, Applicative, MonadCont, MonadIO)

instance MonadFail (InputM spy) where
  fail _ = continue

-- | Lifts a W action to an InputM action.
instance W.Wlike (InputM spy) where
  liftW = InputM . lift . lift

-- | Resets the input handler to the top.
continue :: InputM spy a
continue = do
  (InputContext {inputTop = (InputM top)}) <- InputM ask
  InputM $ shiftT (\_ -> resetT top)

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

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

-- | Executes a function if the input event is a key event. If it is not a key
-- event, then nothing happens.
whenKeyEvent :: (Monad m) => InputEvent -> (KeyEvent.KeyEvent -> m ()) -> m ()
whenKeyEvent (InputKeyEvent ke) = ($ ke)
whenKeyEvent _ = const (return ())

-- | Executes a function in the input event is a button event. If it is not a
-- button event, then nothing happens.
whenButtonEvent ::
  (Monad m) => InputEvent -> (ButtonEvent.ButtonEvent -> m ()) -> m ()
whenButtonEvent (InputButtonEvent be) = ($ be)
whenButtonEvent _ = const (return ())

-- | Forwards the given input event to focused window.
forwardEvent :: (W.Wlike m) => InputEvent -> m ()
forwardEvent = \case
  InputKeyEvent kv -> W.liftW $ forwardKey kv
  InputButtonEvent _ -> return ()

-- | "Unwraps" a maybe. If the maybe is present, the handler proceeds. If the
-- maybe is not present, the handler restarts execution from the top.
unwrap :: Maybe a -> InputM spy a
unwrap (Just val) = return val
unwrap Nothing = continue

-- | Runs the series of events from the top as if they were input.
replayEvents :: [InputEvent] -> InputM spy ()
replayEvents events = do
  ioref <- liftIO (newIORef events)

  (InputM oldInput) <- InputM $ gets inputSource

  let newInput =
        InputM $
          shiftT
            ( \thingToDo -> do
                r <- liftIO (readIORef ioref)
                case r of
                  [] -> do
                    modify $ \st -> st {inputSource = InputM oldInput}
                    a <- oldInput
                    lift (thingToDo a)
                  (a : as) -> do
                    liftIO (writeIORef ioref as)
                    lift (thingToDo a)
            )

  InputM $ modify $ \st -> st {inputSource = newInput}
  where
    delay to act = liftIO (threadDelay to) >> act

-- | Call in the reset handler with the InputM handler you wolud like to use.
useInputHandler :: (InputProxy spy) => InputM spy () -> W ()
useInputHandler (forever -> top@(InputM ctop)) = do
  void $ execRWST (runContT ctop return) (InputContext top) (InputState useSeatEvents)

-- | Returns the next input event that's either a kep press or a button press.
nextInputPressEvent :: InputM spy InputEvent
nextInputPressEvent = nextInputEventThat (andM [isPressEvent, not . modifierKey])

modifierKey :: InputEvent -> Bool
modifierKey (InputKeyEvent (KeyEvent.KeyEvent {codepoint = '\NUL'})) = True
modifierKey _ = False

nextInputEventThat :: (InputEvent -> Bool) -> InputM spy InputEvent
nextInputEventThat fn =
  nextInputEvent
    >>= ( \ie ->
            if fn ie
              then return ie
              else forwardEvent ie >> nextInputEventThat fn
        )

isKeyEvent :: InputEvent -> Bool
isKeyEvent (InputKeyEvent _) = True
isKeyEvent _ = False

isPressEvent :: InputEvent -> Bool
isPressEvent (InputButtonEvent be)
  | ButtonEvent.state be == ButtonEvent.ButtonPressed =
    True
isPressEvent (InputKeyEvent ke)
  | KeyEvent.state ke == KeyEvent.KeyPressed =
    True
isPressEvent _ = False

-- | Returns the event only if it matches the filter. If it does not match the
-- filter, execution resets to the top.
filterEvent :: (InputEvent -> Bool) -> InputEvent -> InputM spy InputEvent
filterEvent fn ev | fn ev = return ev
filterEvent _ _ = continue

getModifierState :: W Word32
getModifierState = do
  seat <- W.getSeat
  keyboard <- W.wio $ wlrSeatGetKeyboard seat
  maybe (return 0) (W.wio . wlrKeyboardGetModifiers) (guardNull keyboard)

nextInputEvent :: InputM spy InputEvent
nextInputEvent = join $ InputM $ gets inputSource

withProxies :: Proxy spy -> InputM spy a -> InputM spy a
withProxies _ = id

-- | Gets the next input event.
useSeatEvents :: forall spy. (InputProxy spy) => InputM spy InputEvent
useSeatEvents =
  InputM $
    shiftT
      ( \thingToDo -> do
          putButtonHandler $ \be -> do
            runSpies thingToDo (InputButtonEvent be)

          putKeyHandler $ \ke -> do
            runSpies thingToDo (InputKeyEvent ke)
      )
  where
    runSpies fn ev = do
      evM <- lift $ runMaybeT (onKeyEvent (Proxy :: Proxy spy) ev)
      mapM_
        ( \ev' -> do
            clearButtonHandler
            clearKeyHandler
            fn ev'
        )
        evM

    clearButtonHandler =
      lift $
        modify $ \st ->
          st
            { W.currentHooks =
                (W.currentHooks st)
                  { W.buttonHook = const (return ())
                  }
            }

    clearKeyHandler =
      lift $
        modify $ \st ->
          st
            { W.currentHooks =
                (W.currentHooks st)
                  { W.keyHook = const (return ())
                  }
            }

    putButtonHandler h = lift $ do
      (r, s) <- (,) <$> ask <*> get
      lift $
        modify $ \st ->
          st
            { W.currentHooks =
                (W.currentHooks st)
                  { W.buttonHook = \be -> void (execRWST (h be) r s)
                  }
            }

    putKeyHandler h = lift $ do
      (r, s) <- (,) <$> ask <*> get
      lift $
        modify $ \st ->
          st
            { W.currentHooks =
                (W.currentHooks st)
                  { W.keyHook = \ke -> void (execRWST (h ke) r s)
                  }
            }