Add Input.hs. This will be a more general version of Keys.

1 files changed, 164 insertions, 0 deletions

diff --git a/src/Wetterhorn/Core/Input.hs b/src/Wetterhorn/Core/Input.hs
new file mode 100644
index 0000000..d3fbb0c
--- /dev/null
+++ b/src/Wetterhorn/Core/Input.hs
@@ -0,0 +1,164 @@
+module Wetterhorn.Core.Input
+  ( forwardEvent,
+    forwardKey,
+    whenKeyEvent,
+    whenButtonEvent,
+    InputM,
+    InputEvent,
+    nextInputPressEvent,
+    continue,
+    unwrap,
+    nextInputEvent,
+  )
+where
+
+import Control.Monad (void)
+import Control.Monad.Cont (MonadCont)
+import Control.Monad.RWS (MonadIO, MonadReader (ask), MonadState (get), MonadTrans (lift), RWST, execRWST, modify)
+import Control.Monad.Trans.Cont
+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 (wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard)
+
+-- | Union of event types.
+data InputEvent
+  = InputButtonEvent ButtonEvent.ButtonEvent
+  | InputKeyEvent KeyEvent.KeyEvent
+
+-- | Context for the input.
+newtype InputContext = InputContext
+  { -- | Top of the input routine. Used in "continue" statement.
+    inputTop :: InputM ()
+  }
+
+-- | Input monad for handling all kinds of input.
+newtype InputM a = InputM (ContT () (RWST InputContext () () W) a)
+  deriving (Monad, Functor, Applicative, MonadCont, MonadIO)
+
+-- | Lifts a W action to an InputM action.
+instance W.Wlike InputM where
+  liftW = InputM . lift . lift
+
+-- | Resets the input handler to the top.
+continue :: InputM 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 :: InputEvent -> (KeyEvent.KeyEvent -> InputM ()) -> InputM ()
+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 ::
+  InputEvent -> (ButtonEvent.ButtonEvent -> InputM ()) -> InputM ()
+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 a
+unwrap (Just val) = return val
+unwrap Nothing = continue
+
+-- | Returns the next input event that's either a kep press or a button press.
+nextInputPressEvent :: InputM InputEvent
+nextInputPressEvent = do
+  nextInputEvent
+    >>= ( \ie -> case ie of
+            InputButtonEvent be
+              | ButtonEvent.state be == ButtonEvent.ButtonPressed ->
+                return ie
+            InputKeyEvent ke
+              | KeyEvent.state ke == KeyEvent.KeyPressed ->
+                return ie
+            _ -> nextInputEvent
+        )
+
+-- | Gets the next input event.
+nextInputEvent :: InputM InputEvent
+nextInputEvent =
+  InputM $
+    shiftT
+      ( \thingToDo -> do
+          putButtonHandler $ \be -> do
+            clearButtonHandler
+            clearKeyHandler
+            thingToDo (InputButtonEvent be)
+
+          putKeyHandler $ \ke -> do
+            clearButtonHandler
+            clearKeyHandler
+            thingToDo (InputKeyEvent ke)
+      )
+  where
+    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)
+                  }
+            }