Have the plugin handle more responsibility with keybindings.

The plugin now passes the key events to the Wayland clients.

4 files changed, 72 insertions, 18 deletions

diff --git a/src/Wetterhorn/Core.hs b/src/Wetterhorn/Core.hs
index 2f885f9..4a48f28 100644
--- a/src/Wetterhorn/Core.hs
+++ b/src/Wetterhorn/Core.hs
@@ -34,6 +34,8 @@ import Numeric (showHex)
 import Text.Printf
 import Wetterhorn.Core.ForeignInterface (ForeignInterface)
 import qualified Wetterhorn.Core.ForeignInterface as ForeignInterface
+import Wetterhorn.WlRoots (WlrInputDevice, wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard)
+import Data.Char (chr, ord)
 
 data WContext = WContext
   { ctxForeignInterface :: ForeignInterface,
@@ -79,9 +81,10 @@ data KeyEvent = KeyEvent
     state :: KeyState,
     modifiers :: Word32,
     keysym :: Word32,
-    codepoint :: Char
+    codepoint :: Char,
+    device :: Ptr WlrInputDevice
   }
-  deriving (Show, Read, Ord, Eq)
+  deriving (Show, Ord, Eq)
 
 data WConfig = WConfig
   { keybindingHandler :: KeyEvent -> W Bool,
@@ -91,19 +94,41 @@ data WConfig = WConfig
 defaultBindings :: Map (KeyState, Word32, Word32) (W ())
 defaultBindings =
   Map.fromList
-    [ ((KeyPressed, 0x8, 0x72), requestHotReload),
-      ((KeyPressed, 0x8, 0x6c), requestLog "This is a log statement!\n"),
-      ((KeyPressed, 0x8, 0x71), requestExit 0)
+    [ ((KeyPressed, 0x8, sym 'r'), requestHotReload),
+      ((KeyPressed, 0x8, sym 'l'), requestLog "This is a log statement!\n"),
+      ((KeyPressed, 0x8, sym 't'), wio $ ForeignInterface.doShellExec "alacritty"),
+      ((KeyPressed, 0x9, sym 'T'), wio $ ForeignInterface.doShellExec "gnome-terminal"),
+      ((KeyPressed, 0x8, sym 'c'), wio $ ForeignInterface.doShellExec "pavucontrol"),
+      ((KeyPressed, 0x8, sym 'q'), requestExit 0)
     ]
 
+  where
+    sym = fromIntegral . ord
+
 defaultConfig :: WConfig
 defaultConfig =
   WConfig
     { keybindingHandler = \keyEvent -> do
         i <- incrementState
+        seatPtr <- (wio . ForeignInterface.getSeat . ctxForeignInterface) =<< getWContext
+
         wio $ printf "%d - Got %s\n" i (show keyEvent)
-        maybe (return False) (fmap (const True)) $
-          Map.lookup
+        maybe
+          ( wio $ do
+              wlrSeatSetKeyboard seatPtr (device keyEvent)
+              wlrSeatKeyboardNotifyKey
+                seatPtr
+                (timeMs keyEvent)
+                (keycode keyEvent)
+                ( case state keyEvent of
+                    KeyReleased -> 0
+                    _ -> 1
+                )
+
+              return True
+          )
+          (fmap (const True))
+          $ Map.lookup
             (state keyEvent, modifiers keyEvent, keysym keyEvent)
             defaultBindings,
       surfaceHandler = \state ptr -> wio (printf "Surface %s is %s\n" (showHex (ptrToIntPtr ptr) "") (show state))
diff --git a/src/Wetterhorn/Core/ForeignInterface.hs b/src/Wetterhorn/Core/ForeignInterface.hs
index 14720bb..5dc1454 100644
--- a/src/Wetterhorn/Core/ForeignInterface.hs
+++ b/src/Wetterhorn/Core/ForeignInterface.hs
@@ -4,21 +4,25 @@ module Wetterhorn.Core.ForeignInterface
     ForeignDemarshal (..),
     runForeignDemarshal,
     demarshal,
+    doShellExec
   )
 where
 
 import Control.Monad.State (MonadState (get, put), MonadTrans (lift), StateT, evalStateT)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BC
 import Data.Void (Void)
-import Foreign (Ptr, Storable (peek, sizeOf), castPtr, plusPtr)
-import Foreign.C (CInt (..))
+import Foreign (Ptr, Storable (peek, sizeOf), Word8, castPtr, plusPtr)
+import Foreign.C (CChar, CInt (..))
 import Foreign.C.String
 import GHC.Exts (FunPtr)
+import Wetterhorn.WlRoots
 
 newtype ForeignDemarshal a = ForeignDemarshal (StateT (Ptr ()) IO a)
   deriving (Functor, Monad, Applicative, MonadState (Ptr ()))
 
-runForeignDemarshal :: Ptr () -> ForeignDemarshal a -> IO a
-runForeignDemarshal p (ForeignDemarshal dm) = evalStateT dm p
+runForeignDemarshal :: Ptr b -> ForeignDemarshal a -> IO a
+runForeignDemarshal p (ForeignDemarshal dm) = evalStateT dm (castPtr p)
 
 demarshal :: (Storable a) => ForeignDemarshal a
 demarshal = do
@@ -29,6 +33,8 @@ demarshal = do
 
 type CtxT = Ptr Void
 
+type ForeignCallGetPtr = CtxT -> IO (Ptr ())
+
 type ForeignCall = CtxT -> IO ()
 
 type ForeignCallStr = CtxT -> CString -> IO ()
@@ -43,12 +49,20 @@ foreign import ccall "dynamic" toForeignCallStr :: FunPtr ForeignCallStr -> Fore
 
 foreign import ccall "dynamic" toForeignCallInt :: FunPtr ForeignCallInt -> ForeignCallInt
 
+foreign import ccall "dynamic" toForeignCallGetPtr :: FunPtr ForeignCallGetPtr -> ForeignCallGetPtr
+
+foreign import ccall "shell_exec" shellExec :: Ptr CChar -> IO ()
+
 data ForeignInterface = ForeignInterface
   { requestHotReload :: IO (),
     requestLog :: String -> IO (),
-    requestExit :: Int -> IO ()
+    requestExit :: Int -> IO (),
+    getSeat :: IO (Ptr WlrSeat)
   }
 
+doShellExec :: String -> IO ()
+doShellExec str = withCString str shellExec
+
 getForeignInterface :: IO ForeignInterface
 getForeignInterface = do
   ptr <- foreignInterfacePtr
@@ -57,11 +71,13 @@ getForeignInterface = do
     requestHotReloadFn <- demarshal
     doLogFn <- demarshal
     doRequestExit <- demarshal
+    getSeatFn <- demarshal
 
     return $
       ForeignInterface
         { requestHotReload = toForeignCall requestHotReloadFn ctx,
           requestLog = \str ->
             withCString str $ \cs -> toForeignCallStr doLogFn ctx cs,
-          requestExit = toForeignCallInt doRequestExit ctx . fromIntegral
+          requestExit = toForeignCallInt doRequestExit ctx . fromIntegral,
+          getSeat = castPtr <$> toForeignCallGetPtr getSeatFn ctx
         }
diff --git a/src/Wetterhorn/FFI.hs b/src/Wetterhorn/FFI.hs
index 58c1aff..4be7189 100644
--- a/src/Wetterhorn/FFI.hs
+++ b/src/Wetterhorn/FFI.hs
@@ -20,6 +20,7 @@ import Foreign.C (CChar, CInt (..))
 import System.Posix.Types (CIno)
 import Wetterhorn.Core
 import Wetterhorn.Core.ForeignInterface
+import Wetterhorn.WlRoots (WlrEventKeyboardKey, WlrInputDevice)
 
 runForeign :: (WConfig -> W ()) -> Wetterhorn -> IO Wetterhorn
 runForeign fn stblptr = do
@@ -85,7 +86,8 @@ pluginMarshalState stblptr outlen = do
 
 foreign export ccall "plugin_handle_keybinding"
   pluginHandleKeybinding ::
-    Ptr () ->
+    Ptr WlrInputDevice ->
+    Ptr WlrEventKeyboardKey ->
     Word32 ->
     Word32 ->
     Word32 ->
@@ -94,14 +96,15 @@ foreign export ccall "plugin_handle_keybinding"
     IO Wetterhorn
 
 pluginHandleKeybinding ::
-  Ptr () ->
+  Ptr WlrInputDevice ->
+  Ptr WlrEventKeyboardKey ->
   Word32 ->
   Word32 ->
   Word32 ->
   Ptr CInt ->
   Wetterhorn ->
   IO Wetterhorn
-pluginHandleKeybinding eventPtr mods sym cp =
+pluginHandleKeybinding inputDevicePtr eventPtr mods sym cp =
   runForeignWithReturn $ \config -> do
     event <- wio $
       runForeignDemarshal eventPtr $ do
@@ -117,6 +120,7 @@ pluginHandleKeybinding eventPtr mods sym cp =
             mods
             sym
             (toEnum $ fromIntegral cp)
+            inputDevicePtr
     (\b -> if b then 1 else 0) <$> keybindingHandler config event
 
 foreign export ccall "plugin_handle_surface_map"
diff --git a/src/harness_adapter.c b/src/harness_adapter.c
index 8663b6a..3834a2c 100644
--- a/src/harness_adapter.c
+++ b/src/harness_adapter.c
@@ -5,6 +5,8 @@
 
 #include "HsFFI.h"
 #include "plugin_interface.h"
+#include <stdio.h>
+#include <stdlib.h>
 #include <unistd.h>
 
 const char *plugin_name = "Wetterhorn";
@@ -20,7 +22,7 @@ extern void performMajorGC();
 
 void plugin_metaload(int argc, char** argv)
 {
-  hs_init(&argc, &argv);
+  // hs_init(&argc, &argv);
 }
 
 void plugin_load(int argc, char **argv, foreign_interface_t* fintf) {
@@ -34,7 +36,7 @@ void plugin_teardown(opqst_t st) {
   //
   // Used primarily in the case where the RTS is kept alive when performing a
   // hot-reload.
-  performMajorGC();
+  // performMajorGC();
   hs_exit();
 
   // There's a race condition between when this shared library is unloaded and
@@ -43,6 +45,13 @@ void plugin_teardown(opqst_t st) {
   sleep(1);
 }
 
+void shell_exec(const char* cmd) {
+  if (fork() == 0) {
+    execl("/bin/sh", "/bin/sh", "-c", cmd, NULL);
+    exit(1);
+  }
+}
+
 static const char msg[] =
     "Wetterhorn Plugin v 0.01\n\n"
     "Welcome, and thank you for your interest.\n\n"