Implementing button presses and integrating it with the KeysM monad.

6 files changed, 119 insertions, 29 deletions

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