Implementing button presses and integrating it with the KeysM monad.

8 files changed, 145 insertions, 46 deletions

diff --git a/harness/include/plugin.h b/harness/include/plugin.h
index c48a2f5..be3a022 100644
--- a/harness/include/plugin.h
+++ b/harness/include/plugin.h
@@ -8,6 +8,7 @@
 #include <stdlib.h>
 #include <wlr/types/wlr_input_device.h>
 #include <wlr/types/wlr_keyboard.h>
+#include <wlr/types/wlr_pointer.h>
 
 #include "plugin_types.h"
 #include <foreign_intf.h>
@@ -24,6 +25,7 @@
 EXPORT_INCLUDE(<foreign_intf.h>)
 EXPORT_INCLUDE(<wlr/types/wlr_keyboard.h>)
 EXPORT_INCLUDE(<wlr/types/wlr_input_device.h>)
+EXPORT_INCLUDE(<wlr/types/wlr_pointer.h>)
 // clang-format on
 
 #define MAX_QUEUED_ACTIONS 8
@@ -139,9 +141,12 @@ typedef struct PLUGIN {
    * Handles a keybinding.
    */
   EXPORT(opqst_t (*plugin_handle_keybinding)(
-      struct wlr_keyboard *keyboard,
-      struct wlr_keyboard_key_event *event, uint32_t modifiers, uint32_t keysym,
-      uint32_t codepoint, int *out_handled, opqst_t state));
+      struct wlr_keyboard *keyboard, struct wlr_keyboard_key_event *event,
+      uint32_t modifiers, uint32_t keysym, uint32_t codepoint, int *out_handled,
+      opqst_t state));
+
+  EXPORT(opqst_t (*plugin_handle_button)(struct wlr_pointer_button_event *event,
+                                         opqst_t state));
 
   /*
    * Handles a surface being mapped, unmapped or destroyed.
diff --git a/harness/src/wl.c b/harness/src/wl.c
index 2cefe06..8b7f437 100644
--- a/harness/src/wl.c
+++ b/harness/src/wl.c
@@ -455,21 +455,25 @@ static void server_cursor_button(struct wl_listener *listener, void *data)
   struct tinywl_server *server =
       wl_container_of(listener, server, cursor_button);
   struct wlr_pointer_button_event *event = data;
+
+  plugin_call_update_state(server->plugin, plugin_handle_button, event);
+
   /* Notify the client with pointer focus that a button press has occurred */
-  wlr_seat_pointer_notify_button(server->seat, event->time_msec, event->button,
-                                 event->state);
-  double sx, sy;
-  struct wlr_surface *surface = NULL;
-  struct tinywl_toplevel *toplevel = desktop_toplevel_at(
-      server, server->cursor->x, server->cursor->y, &surface, &sx, &sy);
-  if (event->state == WLR_BUTTON_RELEASED) {
-    /* If you released any buttons, we exit interactive move/resize mode. */
-    reset_cursor_mode(server);
-  }
-  else {
-    /* Focus that client if the button was _pressed_ */
-    focus_toplevel(toplevel, surface);
-  }
+  // wlr_seat_pointer_notify_button(server->seat, event->time_msec,
+  // event->button,
+  //                                event->state);
+  // double sx, sy;
+  // struct wlr_surface *surface = NULL;
+  // struct tinywl_toplevel *toplevel = desktop_toplevel_at(
+  //     server, server->cursor->x, server->cursor->y, &surface, &sx, &sy);
+  // if (event->state == WLR_BUTTON_RELEASED) {
+  //   /* If you released any buttons, we exit interactive move/resize mode. */
+  //   reset_cursor_mode(server);
+  // }
+  // else {
+  //   /* Focus that client if the button was _pressed_ */
+  //   focus_toplevel(toplevel, surface);
+  // }
 }
 
 static void server_cursor_axis(struct wl_listener *listener, void *data)
diff --git a/src/Config.hs b/src/Config.hs
index e71f48a..5f09cbe 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -20,36 +20,41 @@ config =
       layout = WindowLayout Full,
       resetHook = do
         useKeysWithContinuation recordMacroContinuation $ do
-          kp <- nextKeyPress
+          ev <- nextButtonOrKeyPress
 
-          bind kp (Mod1 .+ 'q') macroKeyBind
+          case ev of
+            Right kp -> do
+              bind kp (Mod1 .+ 'q') macroKeyBind
 
-          bind kp (weak $ Mod1 .+ '@') replayMacroKeybind
+              bind kp (weak $ Mod1 .+ '@') replayMacroKeybind
 
-          bind kp (Mod1 .+ 'r') (shellExec "wofi --show run")
+              bind kp (Mod1 .+ 'r') (shellExec "wofi --show run")
 
-          bind kp (Shift .+ Mod1 .+ 'R') requestHotReload
+              bind kp (Shift .+ Mod1 .+ 'R') requestHotReload
 
-          bind kp (Mod1 .+ 't') (shellExec "alacritty")
+              bind kp (Mod1 .+ 't') (shellExec "alacritty")
 
-          bind kp (Mod1 .+ 'n') (return () :: W ())
+              bind kp (Mod1 .+ 'n') (return () :: W ())
 
-          bind kp (weak $ Mod1 .+ '∫') (shellExec "gxmessage hi")
+              bind kp (weak $ Mod1 .+ '∫') (shellExec "gxmessage hi")
 
-          bind kp (Mod1 .+ 'p') $ do
-            str <-
-              unfoldM
-                ( do
-                    ke <- nextKeyPress
-                    return $
-                      if KeyEvent.codepoint ke == '\r'
-                        then Nothing
-                        else Just (KeyEvent.codepoint ke)
-                )
-            liftIO $ putStrLn $ "You input: " ++ str
-            bind kp (str == "hello") $ do
-              wio $ putStrLn "You Win! *\\o/*"
-            liftIO $ putStrLn "You lose :("
+              bind kp (Mod1 .+ 'p') $ do
+                str <-
+                  unfoldM
+                    ( do
+                        ke <- nextKeyPress
+                        return $
+                          if KeyEvent.codepoint ke == '\r'
+                            then Nothing
+                            else Just (KeyEvent.codepoint ke)
+                    )
+                liftIO $ putStrLn $ "You input: " ++ str
+                bind kp (str == "hello") $ do
+                  wio $ putStrLn "You Win! *\\o/*"
+                liftIO $ putStrLn "You lose :("
 
-          forwardEvent kp
+              forwardEvent kp
+
+            Left but ->
+              liftIO $ putStrLn $ "ButtonEvent! " ++ (show but)
     }
diff --git a/src/Wetterhorn/Core/ButtonEvent.hs b/src/Wetterhorn/Core/ButtonEvent.hs
new file mode 100644
index 0000000..d3e0763
--- /dev/null
+++ b/src/Wetterhorn/Core/ButtonEvent.hs
@@ -0,0 +1,14 @@
+module Wetterhorn.Core.ButtonEvent where
+
+import Wetterhorn.Foreign.WlRoots
+import Data.Word (Word32)
+import Foreign (Ptr)
+
+data ButtonState = ButtonReleased | ButtonPressed deriving (Show, Read, Eq, Enum, Ord)
+
+data ButtonEvent = ButtonEvent {
+  pointer :: Ptr WlrPointer,
+  timeMs :: Word32,
+  button :: Word32,
+  state :: ButtonState
+} deriving (Eq, Show, Ord)
diff --git a/src/Wetterhorn/Core/Keys.hs b/src/Wetterhorn/Core/Keys.hs
index d82ac4c..54d7125 100644
--- a/src/Wetterhorn/Core/Keys.hs
+++ b/src/Wetterhorn/Core/Keys.hs
@@ -3,12 +3,14 @@ module Wetterhorn.Core.Keys where
 import Control.Monad (forever, void, when)
 import Control.Monad.Cont.Class
 import Control.Monad.IO.Class
-import Control.Monad.State (MonadState (get, put), MonadTrans (lift), StateT, evalStateT, gets)
+import Control.Monad.State (MonadState (get, put), MonadTrans (lift), StateT, evalStateT, gets, modify)
 import Control.Monad.Trans.Cont
 import Data.Bits
 import Data.Word
+import Wetterhorn.Core.ButtonEvent (ButtonEvent)
 import Wetterhorn.Core.KeyEvent
 import qualified Wetterhorn.Core.KeyEvent as KeyEvent
+import qualified Wetterhorn.Core.ButtonEvent as ButtonEvent
 import Wetterhorn.Core.W
 import Wetterhorn.Foreign.WlRoots (wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard)
 
@@ -114,6 +116,42 @@ putKeyHandler handler = do
             }
       }
 
+nextButtonEvent :: KeysM ButtonEvent
+nextButtonEvent = do
+  st <- KeysM get
+  KeysM $
+    shiftT $ \h ->
+      lift $ lift $ putButtonHandler (\ev -> evalStateT (h ev) st)
+  where
+    putButtonHandler h = do
+      modify $ \st -> st {currentHooks = (currentHooks st) {buttonHook = h}}
+
+nextButtonOrKeyEvent :: KeysM (Either ButtonEvent KeyEvent)
+nextButtonOrKeyEvent = do
+  st <- KeysM get
+  KeysM $
+    shiftT $ \rest -> 
+      lift $ lift $ do
+        putButtonHandler (\ev -> evalStateT (rest (Left ev)) st)
+        handleContinuation st (\ev -> evalStateT (rest (Right ev)) st)
+
+  where
+    putButtonHandler h = do
+      modify $ \st -> st {currentHooks = (currentHooks st) {buttonHook = h}}
+
+nextButtonOrKeyPress :: KeysM (Either ButtonEvent KeyEvent)
+nextButtonOrKeyPress = do
+  ev <- nextButtonOrKeyEvent
+  case ev of
+    Left bev | ButtonEvent.state bev == ButtonEvent.ButtonPressed -> return ev
+    Left bev -> forwardButtonEvent bev >> nextButtonOrKeyPress
+    Right kev | KeyEvent.state kev == KeyEvent.KeyPressed -> return ev
+    Right kev -> forwardEvent kev >> nextButtonOrKeyPress
+
+ where
+   forwardButtonEvent _ = return ()
+  
+
 -- | Returns the next KeyPressed event. This is likely what 90% of use cases
 -- want rather than nextKeyEvent.
 nextKeyPress :: KeysM KeyEvent
diff --git a/src/Wetterhorn/Core/W.hs b/src/Wetterhorn/Core/W.hs
index 3b77ba8..c252d59 100644
--- a/src/Wetterhorn/Core/W.hs
+++ b/src/Wetterhorn/Core/W.hs
@@ -28,6 +28,7 @@ import qualified Wetterhorn.Foreign.ForeignInterface as ForeignInterface
 import Wetterhorn.Foreign.WlRoots (Surface, WlrSeat)
 import Wetterhorn.StackSet hiding (layout)
 import qualified Wetterhorn.StackSet as StackSet
+import Wetterhorn.Core.ButtonEvent (ButtonEvent)
 
 data RationalRect = RationalRect Rational Rational Rational Rational
 
@@ -137,7 +138,8 @@ defaultHooks :: Hooks
 defaultHooks =
   Hooks
     { keyHook = \_ -> return (),
-      surfaceHook = handleSurface
+      surfaceHook = handleSurface,
+      buttonHook = \_ -> return ()
     }
 
 defaultConfig :: Config ()
@@ -150,7 +152,8 @@ defaultConfig =
 
 data Hooks = Hooks
   { keyHook :: KeyEvent -> W (),
-    surfaceHook :: SurfaceEvent -> W ()
+    surfaceHook :: SurfaceEvent -> W (),
+    buttonHook :: ButtonEvent -> W ()
   }
 
 data Config l = Config
diff --git a/src/Wetterhorn/Foreign/Export.hs b/src/Wetterhorn/Foreign/Export.hs
index d1f83f5..3d24766 100644
--- a/src/Wetterhorn/Foreign/Export.hs
+++ b/src/Wetterhorn/Foreign/Export.hs
@@ -5,8 +5,8 @@ module Wetterhorn.Foreign.Export () where
 import Config
 import Control.Arrow (Arrow (first))
 import Control.Monad (forM_)
-import Data.ByteString qualified as BS
-import Data.ByteString.Char8 qualified as CH
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as CH
 import Foreign
   ( Ptr,
     Storable (poke, pokeByteOff),
@@ -18,10 +18,11 @@ import Foreign
     newStablePtr,
   )
 import Foreign.C (CChar, CInt (..))
+import Wetterhorn.Core.ButtonEvent (ButtonEvent (ButtonEvent), ButtonState (ButtonPressed, ButtonReleased))
 import Wetterhorn.Core.KeyEvent (KeyEvent (..), KeyState (..))
 import Wetterhorn.Core.SurfaceEvent (SurfaceEvent (SurfaceEvent))
 import Wetterhorn.Core.W (W, Wetterhorn)
-import Wetterhorn.Core.W qualified as W
+import qualified Wetterhorn.Core.W as W
 import Wetterhorn.Foreign.ForeignInterface
 import Wetterhorn.Foreign.WlRoots
 
@@ -99,6 +100,31 @@ pluginMarshalState stblptr outlen = do
     pokeByteOff ret off w8
   return ret
 
+foreign export ccall "plugin_handle_button"
+  pluginHandleButton :: Ptr WlrPointerButtonEvent -> Wetterhorn -> IO Wetterhorn
+
+pluginHandleButton :: Ptr WlrPointerButtonEvent -> Wetterhorn -> IO Wetterhorn
+pluginHandleButton eventPtr = do
+  runForeign $
+    \( _,
+       W.State {W.currentHooks = W.Hooks {buttonHook = buttonHook}}
+       ) -> do
+        event <- W.wio $
+          runForeignDemarshal eventPtr $ do
+            ButtonEvent
+              <$> demarshal
+              <*> demarshal
+              <*> demarshal
+              <*> ( ( \u8 ->
+                        if (u8 :: Word8) == 0
+                          then ButtonReleased
+                          else ButtonPressed
+                    )
+                      <$> demarshal
+                  )
+
+        buttonHook event
+
 foreign export ccall "plugin_handle_keybinding"
   pluginHandleKeybinding ::
     Ptr WlrInputDevice ->
diff --git a/src/Wetterhorn/Foreign/WlRoots.hs b/src/Wetterhorn/Foreign/WlRoots.hs
index ed6bc1c..05ed3d6 100644
--- a/src/Wetterhorn/Foreign/WlRoots.hs
+++ b/src/Wetterhorn/Foreign/WlRoots.hs
@@ -3,6 +3,10 @@ module Wetterhorn.Foreign.WlRoots where
 import Foreign (IntPtr, Ptr, Word32, intPtrToPtr, ptrToIntPtr)
 import Text.Read
 
+data WlrPointer
+
+data WlrPointerButtonEvent
+
 data WlrSeat
 
 data WlrInputDevice