Added a new KeysM monad.

This monad allows keybindings to look and feel like one is writing
blocking code with constructs like:

key <- nextKey
when (key == x) $ do
  key2 <- nextKey
  ...
...

but this code does not block or do any io shenanigans, it under the hood
just changes the handler on the state. It seems pretty awesome and opens
the doors for some pretty expressive key bindings.

6 files changed, 408 insertions, 98 deletions

diff --git a/harness/src/wl.c b/harness/src/wl.c
index 1535c6d..0bd0410 100644
--- a/harness/src/wl.c
+++ b/harness/src/wl.c
@@ -87,34 +87,6 @@ static void keyboard_handle_modifiers(struct wl_listener *listener, void *data)
                                      &keyboard->wlr_keyboard->modifiers);
 }
 
-static bool handle_keybinding(struct tinywl_server *server, xkb_keysym_t sym)
-{
-  /*
-   * Here we handle compositor keybindings. This is when the compositor is
-   * processing keys, rather than passing them on to the client for its own
-   * processing.
-   *
-   * This function assumes Alt is held down.
-   */
-  switch (sym) {
-  case XKB_KEY_Escape:
-    wl_display_terminate(server->wl_display);
-    break;
-  case XKB_KEY_F1:
-    /* Cycle to the next toplevel */
-    if (wl_list_length(&server->toplevels) < 2) {
-      break;
-    }
-    struct tinywl_toplevel *next_toplevel =
-        wl_container_of(server->toplevels.prev, next_toplevel, link);
-    focus_toplevel(next_toplevel, next_toplevel->xdg_toplevel->base->surface);
-    break;
-  default:
-    return false;
-  }
-  return true;
-}
-
 static void keyboard_handle_key(struct wl_listener *listener, void *data)
 {
   /* This event is raised when a key is pressed or released. */
@@ -609,7 +581,7 @@ static void xdg_toplevel_map(struct wl_listener *listener, void *data)
   wl_list_insert(&toplevel->server->toplevels, &toplevel->link);
 
   plugin_call_update_state(toplevel->server->plugin, plugin_handle_surface,
-                           data, SURFACE_MAP);
+                           toplevel, SURFACE_MAP);
 
   focus_toplevel(toplevel, toplevel->xdg_toplevel->base->surface);
 }
@@ -625,7 +597,7 @@ static void xdg_toplevel_unmap(struct wl_listener *listener, void *data)
   }
 
   plugin_call_update_state(toplevel->server->plugin, plugin_handle_surface,
-                           data, SURFACE_UNMAP);
+                           toplevel, SURFACE_UNMAP);
 
   wl_list_remove(&toplevel->link);
 }
@@ -645,7 +617,7 @@ static void xdg_toplevel_destroy(struct wl_listener *listener, void *data)
   wl_list_remove(&toplevel->request_fullscreen.link);
 
   plugin_call_update_state(toplevel->server->plugin, plugin_handle_surface,
-                           data, SURFACE_DELETE);
+                           toplevel, SURFACE_DELETE);
 
   free(toplevel);
 }
diff --git a/package.yaml b/package.yaml
index e5e199b..3a7c5b2 100644
--- a/package.yaml
+++ b/package.yaml
@@ -56,6 +56,7 @@ ghc-options:
 - -XDefaultSignatures
 - -XViewPatterns
 - -XDerivingVia
+- -XDisambiguateRecordFields
 - -fPIC
 
 executables:
diff --git a/src/Config.hs b/src/Config.hs
index e49a869..87a0277 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -1,14 +1,23 @@
-module Config where
+module Config (config) where
 
+import Wetterhorn.Core.Keys
 import Wetterhorn.Core.W
 import Wetterhorn.Layout.Full
-import Wetterhorn.Layout.Combine
 
-config = defaultConfig {
-  keyHook = wio . print,
-  surfaceHook = wio . print,
-  layout = WindowLayout Full
-}
+config :: Config WindowLayout
+config =
+  defaultConfig
+    { hooks =
+        defaultHooks
+          { keyHook = ofKeys testKeys,
+              -- runKeybinds $ do
+              --   bind (Mod1 .+ 'r') (shellExec "wofi --show run")
 
--- wetterhorn :: IO Wetterhorn
--- wetterhorn = initWetterhorn defaultConfig
+              --   subbind (Mod1 .+ 'g') $ do
+              --     bind 't' $ shellExec "alacritty"
+
+              --   bind (Mod1 .+ 'Q') requestHotReload,
+            surfaceHook = wio . print
+          },
+      layout = WindowLayout Full
+    }
diff --git a/src/Wetterhorn/Core/Keys.hs b/src/Wetterhorn/Core/Keys.hs
new file mode 100644
index 0000000..d08a49f
--- /dev/null
+++ b/src/Wetterhorn/Core/Keys.hs
@@ -0,0 +1,251 @@
+module Wetterhorn.Core.Keys where
+
+import Control.Monad.Reader (MonadReader (ask), MonadTrans (lift), ReaderT (runReaderT), asks, void, when)
+import Control.Monad.State (MonadState (get, put), gets)
+import Data.Bits
+import Data.Kind
+import Data.Word
+import Wetterhorn.Core.KeyEvent
+import qualified Wetterhorn.Core.KeyEvent as KeyEvent
+import Wetterhorn.Core.W
+import Wetterhorn.Foreign.WlRoots (wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard)
+
+-- | Passes a key event through the current seat.
+passThroughKey :: KeyEvent -> W ()
+passThroughKey keyEvent = do
+  seatPtr <- getSeat
+  wio $ do
+    wlrSeatSetKeyboard
+      seatPtr
+      (device keyEvent)
+
+    wlrSeatKeyboardNotifyKey
+      seatPtr
+      (timeMs keyEvent)
+      (keycode keyEvent)
+      ( case state keyEvent of
+          KeyReleased -> 0
+          _ -> 1
+      )
+
+data Binding = Skip | Nevermind | JustAction (W ())
+
+newtype Keybinds a = Keybinds (ReaderT KeyEvent (Either (Maybe (W ()))) a)
+  deriving (Functor, Applicative, Monad, MonadReader KeyEvent)
+
+runKeybinds :: Keybinds a -> KeyEvent -> W ()
+runKeybinds (Keybinds kb) ke =
+  case runReaderT kb ke of
+    Left (Just action) -> action
+    _ -> do
+      resetKeys
+      passThroughKey ke
+
+resetKeys :: W ()
+resetKeys = do
+  Config {hooks = Hooks {keyHook = originalKeyHook}} <- ask
+  s@State {currentHooks = hooks} <- get
+  put s {currentHooks = hooks {keyHook = originalKeyHook}}
+
+-- subbind :: Keybinds a -> W ()
+-- subbind kb = do
+--   s@State {currentHooks = hooks} <- get
+--   put s {currentHooks = hooks {keyHook = runKeybinds kb}}
+
+data Modifier = Shift | Lock | Control | Mod1 | Mod2 | Mod3 | Mod4 | Mod5
+
+modifierToMask :: Modifier -> Word32
+modifierToMask m =
+  1
+    `shiftL` case m of
+      Shift -> 0
+      Lock -> 1
+      Control -> 2
+      Mod1 -> 3
+      Mod2 -> 4
+      Mod3 -> 5
+      Mod4 -> 6
+      Mod5 -> 7
+
+-- class MatchesKeyEvent a where
+--   matchesKeyEvent :: a -> KeyEvent -> Bool
+--
+-- instance MatchesKeyEvent Modifier where
+--   matchesKeyEvent m keyEvent =
+--     (modifiers keyEvent .&. modifierToMask m) /= 0
+--
+-- instance MatchesKeyEvent Char where
+--   matchesKeyEvent c e = c == codepoint e
+--
+-- newtype Match = Match (KeyEvent -> Bool)
+--
+-- instance MatchesKeyEvent Match where
+--   matchesKeyEvent (Match f) = f
+--
+-- (.+) :: (MatchesKeyEvent m1, MatchesKeyEvent m2) => m1 -> m2 -> Match
+-- (.+) match1 match2 = Match $ \ke -> matchesKeyEvent match1 ke && matchesKeyEvent match2 ke
+--
+-- bind :: (MatchesKeyEvent m) => m -> W () -> Keybinds ()
+-- bind condition action = do
+--   ke <- ask
+--   when (state ke == KeyPressed && matchesKeyEvent condition ke) $
+--     Keybinds $
+--       lift (Left $ Just (action >> resetKeys))
+--   when (state ke == KeyReleased && matchesKeyEvent condition ke) (return ())
+--
+-- subbind :: (MatchesKeyEvent m) => m -> Keybinds () -> Keybinds ()
+-- subbind condition subkeys = do
+--   ke <- ask
+--   when (state ke == KeyPressed && matchesKeyEvent condition ke) $
+--     Keybinds $
+--       lift
+--         ( Left $
+--             Just $
+--               nextKey (runKeybinds subkeys)
+--         )
+--   when (state ke == KeyReleased && matchesKeyEvent condition ke) (return ())
+--
+-- nevermind :: Keybinds ()
+-- nevermind = Keybinds $ lift (Left Nothing)
+
+testKeys :: KeysM ()
+testKeys = do
+  k1 <- nextKeyPress
+
+  when (KeyEvent.codepoint k1 == 'R') $
+    liftW requestHotReload
+
+  liftW $ wio $ putStrLn $ "1 " ++ show k1
+  ck <- currentKey
+  liftW $ wio $ putStrLn $ "1' " ++ show ck
+  k2 <- nextKeyPress
+  liftW $ wio $ putStrLn $ "2 " ++ show k2
+  testKeys
+
+newtype KeysM a = KeysM (KeyEvent -> W (Either (KeysM a) a))
+
+ofKeys :: KeysM a -> KeyEvent -> W ()
+ofKeys (KeysM fn) ke = do
+  e <- fn ke
+  case e of
+    Right _ -> return ()
+    Left next -> runKeysM next
+
+runKeysM :: KeysM a -> W ()
+runKeysM k = do
+  s@State {currentHooks = hooks} <- get
+  put
+    s
+      { currentHooks =
+          hooks
+            { keyHook = ofKeys k
+            }
+      }
+
+liftW :: W a -> KeysM a
+liftW act = KeysM (\_ -> Right <$> act)
+
+keysJoin :: KeysM (KeysM a) -> KeysM a
+keysJoin (KeysM f) = KeysM $ \keyEvent -> do
+  e <- f keyEvent
+  case e of
+    Right (KeysM f') -> f' keyEvent
+    Left sub -> return $ Left $ keysJoin sub
+
+nextKey :: KeysM KeyEvent
+nextKey = KeysM (\_ -> return (Left (KeysM (return . Right))))
+
+nextKeyPress :: KeysM KeyEvent
+nextKeyPress = do
+  k <- nextKey
+  if KeyEvent.state k /= KeyPressed
+    then nextKeyPress
+    else return k
+
+currentKey :: KeysM KeyEvent
+currentKey = KeysM (return . Right)
+
+instance Functor KeysM where
+  fmap f (KeysM fn) = KeysM $ \keyEvent -> do
+    e <- fn keyEvent
+    return $
+      case e of
+        Left ma -> Left $ fmap f ma
+        Right a -> Right $ f a
+
+instance Applicative KeysM where
+  pure a = KeysM (\_ -> return (Right a))
+  (<*>) mfn ma = do
+    fn <- mfn
+    fn <$> ma
+
+instance Monad KeysM where
+  return = pure
+  a >>= fmb = keysJoin (fmap fmb a)
+
+-- keysJoin (KeysM fn) = KeysM $ \ke -> do
+--   nextKeys <- fn ke
+--   case nextKeys of
+--     NextKey -> NextKey
+--     (KeysM fn') -> fn' ke
+
+-- data KeysResult a = DoDefer (KeyEvent -> W (KeysM a)) | DoIdent a
+-- data KeysM a = KeysM (KeyEvent -> W (KeysResult a))
+--
+-- keysJoin :: KeysM (KeysM a) -> KeysM a
+-- keysJoin (KeysM fn) = KeysM $ \ke -> do
+--  kr <- fn ke
+--  case kr of
+--    DoDefer nextKeyFn ->
+
+-- data KeysM a where
+--   Ident :: W a -> KeysM a
+--   NextKey :: (KeyEvent -> W (KeysM a)) -> KeysM a
+--
+-- runKeysM :: KeysM a -> KeyEvent -> W ()
+-- runKeysM (Ident ma) _ = void ma
+-- runKeysM (NextKey fn) keyEvent = do
+--   val <- fn keyEvent
+--   s@State {currentHooks = hooks} <- get
+--   put s {currentHooks = hooks {keyHook = runKeysM val}}
+--
+-- instance Functor KeysM where
+--   fmap f (Ident wa) = Ident $ fmap f wa
+--   fmap f (NextKey fn) = NextKey $ fmap (fmap f) . fn
+--
+-- instance Applicative KeysM where
+--   pure = Ident . pure
+--
+--
+-- joinKeysM :: KeysM (KeysM a) -> KeysM a
+-- joinKeysM (Ident mKeysMA) =
+--   Ident $ do
+--     keysMa <- mKeysMA
+--     case keysMa of
+--       Ident ma -> ma
+--       NextKey ->
+--
+-- instance Monad KeysM where
+--   return = pure
+
+-- (Ident ma) >>= fn =
+
+-- nextKey :: (KeyEvent -> W ()) -> W ()
+-- nextKey evf = do
+--   s@State {currentHooks = hooks} <- get
+--   put s {currentHooks = hooks {keyHook = evf}}
+
+--
+-- data KeyM a where
+--   Ident :: W a -> KeyM a
+--   Deferred :: KeyM KeyEvent
+--   Cont :: (KeyEvent -> KeyM b) -> KeyM b
+--
+-- instance Functor KeyM where
+--   fmap fn k = case k of
+--     Ident wa -> Ident (fn <$> wa)
+--     Deferred -> Cont (pure . fn)
+--     Cont f -> Cont (fmap fn . f)
+
+-- bind :: KeyM KeyEvent -> (KeyEvent -> KeyM b) -> KeyM b
+-- bind = undefined
diff --git a/src/Wetterhorn/Core/W.hs b/src/Wetterhorn/Core/W.hs
index 11bac05..b2b044e 100644
--- a/src/Wetterhorn/Core/W.hs
+++ b/src/Wetterhorn/Core/W.hs
@@ -1,7 +1,9 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+
 module Wetterhorn.Core.W where
 
 import Control.Arrow (Arrow (first))
-import Control.Monad.RWS (MonadIO (liftIO), MonadReader, MonadState)
+import Control.Monad.RWS (MonadIO (liftIO), MonadReader (..), MonadState)
 import Control.Monad.Reader (ReaderT (runReaderT))
 import Control.Monad.State (StateT (runStateT))
 import Control.Monad.Trans.Maybe
@@ -12,8 +14,9 @@ import Foreign (Ptr, StablePtr, intPtrToPtr, ptrToIntPtr)
 import Text.Read
 import Wetterhorn.Core.KeyEvent
 import Wetterhorn.Core.SurfaceEvent
-import Wetterhorn.Foreign
-import Wetterhorn.Foreign.ForeignInterface (ForeignInterface)
+import Wetterhorn.Foreign.ForeignInterface (ForeignInterface (ForeignInterface))
+import qualified Wetterhorn.Foreign.ForeignInterface as ForeignInterface
+import Wetterhorn.Foreign.WlRoots (WlrSeat)
 import Wetterhorn.StackSet hiding (layout)
 
 data RationalRect = RationalRect Rational Rational Rational Rational
@@ -87,7 +90,7 @@ handleWindowMessage m (WindowLayout l) = WindowLayout <$> handleMessage m l
 readWindowLayout :: WindowLayout -> String -> WindowLayout
 readWindowLayout (WindowLayout l) s
   | (Just x) <- readLayout s =
-    WindowLayout (asTypeOf x l)
+      WindowLayout (asTypeOf x l)
 readWindowLayout l _ = l
 
 serializeWindowLayout :: WindowLayout -> String
@@ -118,45 +121,105 @@ data Context = Context
     ctxConfig :: Config WindowLayout
   }
 
+defaultHooks :: Hooks
+defaultHooks =
+  Hooks
+    { keyHook = \_ -> return (),
+      surfaceHook = \_ -> return ()
+    }
+
 defaultConfig :: Config ()
 defaultConfig =
   Config
-    { keyHook = \_ -> return (),
-      surfaceHook = \_ -> return (),
+    { hooks = defaultHooks,
       layout = ()
     }
 
-data Config l = Config
+data Hooks = Hooks
   { keyHook :: KeyEvent -> W (),
-    surfaceHook :: SurfaceEvent -> W (),
-    layout :: l
+    surfaceHook :: SurfaceEvent -> W ()
   }
 
-data State = State
-  { mapped :: StackSet ScreenId ScreenDetail Tag WindowLayout Window,
-    allWindows :: Set Window
+data Config l = Config
+  { layout :: l,
+    hooks :: Hooks
   }
 
-initColdState :: WindowLayout -> IO State
-initColdState l = return $ State (StackSet (Screen () () (Workspace "0" l (Stack [] []))) [] []) mempty
+data State = State
+  { -- The datastructure containing the state of the windows.
+    mapped :: StackSet ScreenId ScreenDetail Tag WindowLayout Window,
+    -- | All the windows wetterhorn knows about, even if they are not mapped.
+    allWindows :: Set Window,
+    -- | Current set of hooks. The initial hooks are provided by the
+    -- configuration, but the hooks can change during operation. This is how key
+    -- sequences can be mapped.
+    currentHooks :: Hooks
+  }
 
+-- | Initializes a "cold" state from a configuration. A cold state is the
+-- initial state on startup. It is constrasted with a "hot" state, which is a
+-- persisted state after a hot-reload.
+initColdState :: Config WindowLayout -> IO State
+initColdState Config {layout = layout, hooks = hooks} =
+  return $
+    State
+      ( StackSet (Screen () () (Workspace "0" layout (Stack [] []))) [] []
+      )
+      mempty
+      hooks
+
+-- | Marshals the serializable parts of the state to a string. This happens
+-- during a hot-reload where some state must be saved to persist across hot
+-- reloads.
 marshalState :: State -> String
-marshalState (State mapped allWindows) =
-  show
-    ( mapLayout serializeWindowLayout mapped,
-      allWindows
-    )
-
-demarshalState :: WindowLayout -> String -> State
-demarshalState witness str = State mapped allWindows
+marshalState
+  ( State
+      { mapped = mapped,
+        allWindows = allWindows
+      }
+    ) =
+    show
+      ( mapLayout serializeWindowLayout mapped,
+        allWindows
+      )
+
+-- | Demarshals the string from "marshalState" into a state. Uses the provided
+-- config to fill out non-persistent parts of the state.
+demarshalState :: Config WindowLayout -> String -> State
+demarshalState Config {hooks = hooks, layout = layout} str =
+  State mapped allWindows hooks
   where
-    (mapLayout (readWindowLayout witness) -> mapped, allWindows) = read str
+    (mapLayout (readWindowLayout layout) -> mapped, allWindows) = read str
 
+-- | This is _the_ main monad used for Wetterhorn operations. Contains
+-- everything required to operate. Contains the state, configuration and
+-- interface to foreign code.
 newtype W a = W (ReaderT Context (StateT State IO) a)
-  deriving (Functor, Applicative, Monad, MonadState State, MonadReader Context, MonadIO)
+  deriving (Functor, Applicative, Monad, MonadState State, MonadIO)
+
+-- | Let Config be the thing W is a reader for. There is already a way to get
+-- the foreign interface in the context.
+instance MonadReader (Config WindowLayout) W where
+  local fn (W r) = W $ local (\(Context fi conf) -> Context fi (fn conf)) r
+  ask = W $ ctxConfig <$> ask
 
 runW :: W a -> (Context, State) -> IO (a, State)
 runW (W fn) (ctx, st) = runStateT (runReaderT fn ctx) st
 
+foreignInterface :: W ForeignInterface
+foreignInterface = W $ ctxForeignInterface <$> ask
+
+getSeat :: W (Ptr WlrSeat)
+getSeat = (wio . ForeignInterface.getSeat) =<< foreignInterface
+
+requestHotReload :: W ()
+requestHotReload = (wio . ForeignInterface.requestHotReload) =<< foreignInterface
+
+requestExit :: Int -> W ()
+requestExit ec = (wio . flip ForeignInterface.requestExit ec) =<< foreignInterface
+
+shellExec :: String -> W ()
+shellExec = wio . ForeignInterface.doShellExec
+
 wio :: IO a -> W a
 wio = liftIO
diff --git a/src/Wetterhorn/Foreign/Export.hs b/src/Wetterhorn/Foreign/Export.hs
index 0d71a4e..e35ed71 100644
--- a/src/Wetterhorn/Foreign/Export.hs
+++ b/src/Wetterhorn/Foreign/Export.hs
@@ -3,6 +3,7 @@
 module Wetterhorn.Foreign.Export () where
 
 import Config
+import Control.Arrow (Arrow (first))
 import Control.Monad (forM_)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as CH
@@ -24,26 +25,31 @@ import qualified Wetterhorn.Core.W as W
 import Wetterhorn.Foreign.ForeignInterface
 import Wetterhorn.Foreign.WlRoots
 
-runForeign :: (forall l. W.Config l -> W ()) -> Wetterhorn -> IO Wetterhorn
+type Wetter = (W.Config W.WindowLayout, W.State)
+
+toWetter :: (W.Context, W.State) -> (W.Config W.WindowLayout, W.State)
+toWetter = first W.ctxConfig
+
+runForeign :: (Wetter -> W ()) -> Wetterhorn -> IO Wetterhorn
 runForeign fn stblptr = do
-  (ctx, st) <- deRefStablePtr stblptr
+  w@(ctx, st) <- deRefStablePtr stblptr
   freeStablePtr stblptr
-  (_, state') <- W.runW (fn $ W.ctxConfig ctx) (ctx, st)
+  (_, state') <- W.runW (fn $ toWetter w) (ctx, st)
   newStablePtr (ctx, state')
 
-runForeignWithReturn :: (Storable a) => (forall l. W.Config l -> W a) -> Ptr a -> Wetterhorn -> IO Wetterhorn
+runForeignWithReturn :: (Storable a) => (Wetter -> W a) -> Ptr a -> Wetterhorn -> IO Wetterhorn
 runForeignWithReturn fn ptr stableptr = do
-  (ctx, st) <- deRefStablePtr stableptr
+  w@(ctx, st) <- deRefStablePtr stableptr
   freeStablePtr stableptr
-  (val, state') <- W.runW (fn $ W.ctxConfig ctx) (ctx, st)
+  (val, state') <- W.runW (fn $ toWetter w) (ctx, st)
   poke ptr val
   newStablePtr (ctx, state')
 
-runForeignWithReturn2 :: (Storable a, Storable b) => (forall l. W.Config l -> W (a, b)) -> Ptr a -> Ptr b -> Wetterhorn -> IO Wetterhorn
+runForeignWithReturn2 :: (Storable a, Storable b) => (Wetter -> W (a, b)) -> Ptr a -> Ptr b -> Wetterhorn -> IO Wetterhorn
 runForeignWithReturn2 fn ptrA ptrB stableptr = do
-  (ctx, st) <- deRefStablePtr stableptr
+  w@(ctx, st) <- deRefStablePtr stableptr
   freeStablePtr stableptr
-  ((vA, vB), state') <- W.runW (fn $ W.ctxConfig ctx) (ctx, st)
+  ((vA, vB), state') <- W.runW (fn $ toWetter w) (ctx, st)
   poke ptrA vA
   poke ptrB vB
   newStablePtr (ctx, state')
@@ -61,7 +67,7 @@ pluginHotStart chars len = do
   foreignInterface <- getForeignInterface
   newStablePtr
     ( W.Context foreignInterface config,
-      W.demarshalState (W.layout config) (CH.unpack bs)
+      W.demarshalState config (CH.unpack bs)
     )
 
 -- | This function is called when a "coldstart" request is receieved. It just
@@ -73,7 +79,7 @@ foreign export ccall "plugin_cold_start"
 pluginColdStart :: IO Wetterhorn
 pluginColdStart = do
   foreignInterface <- getForeignInterface
-  state <- W.initColdState (W.layout config)
+  state <- W.initColdState config
   newStablePtr (W.Context foreignInterface config, state)
 
 -- | Marshals the opaque state to a C-style byte array and size pointer.
@@ -111,24 +117,27 @@ pluginHandleKeybinding ::
   Wetterhorn ->
   IO Wetterhorn
 pluginHandleKeybinding inputDevicePtr eventPtr mods sym cp =
-  runForeignWithReturn $ \config -> do
-    event <- W.wio $
-      runForeignDemarshal eventPtr $ do
-        tMs <- demarshal
-        kc <- demarshal
-        _ <- (demarshal :: ForeignDemarshal Word32)
-        keyState <- demarshal
-        return $
-          KeyEvent
-            tMs
-            kc
-            (if keyState == (0 :: Word8) then KeyReleased else KeyPressed)
-            mods
-            sym
-            (toEnum $ fromIntegral cp)
-            inputDevicePtr
-    W.keyHook config event
-    return 1
+  runForeignWithReturn $
+    \( _,
+       W.State {W.currentHooks = W.Hooks {keyHook = keyHook}}
+       ) -> do
+        event <- W.wio $
+          runForeignDemarshal eventPtr $ do
+            tMs <- demarshal
+            kc <- demarshal
+            _ <- (demarshal :: ForeignDemarshal Word32)
+            keyState <- demarshal
+            return $
+              KeyEvent
+                tMs
+                kc
+                (if keyState == (0 :: Word8) then KeyReleased else KeyPressed)
+                mods
+                sym
+                (toEnum $ fromIntegral cp)
+                inputDevicePtr
+        keyHook event
+        return 1
 
 -- | Function exported to the harness to handle the mapping/unmapping/deletion
 -- of an XDG surface.
@@ -139,10 +148,9 @@ foreign export ccall "plugin_handle_surface"
 pluginHandleSurface :: Ptr WlrXdgSurface -> CInt -> Wetterhorn -> IO Wetterhorn
 pluginHandleSurface p t =
   runForeign
-    ( \c ->
-        W.surfaceHook
-          c
-          $ SurfaceEvent (toEnum $ fromIntegral t) (toSurface p)
+    ( \(_, W.State {currentHooks = W.Hooks {surfaceHook = surfaceHook}}) ->
+        surfaceHook $
+          SurfaceEvent (toEnum $ fromIntegral t) (toSurface p)
     )
 
 -- | Function exported to the harness to handle the mapping/unmapping/deletion
@@ -153,4 +161,10 @@ foreign export ccall "plugin_handle_xwayland_surface"
 
 pluginHandleXWaylandSurface :: Ptr WlrXWaylandSurface -> CInt -> Wetterhorn -> IO Wetterhorn
 pluginHandleXWaylandSurface p t =
-  runForeign (\c -> W.surfaceHook c $ SurfaceEvent (toEnum $ fromIntegral t) (toSurface p))
+  runForeign
+    ( \( _,
+         W.State
+           { currentHooks = W.Hooks {surfaceHook = surfaceHook}
+           }
+         ) -> surfaceHook $ SurfaceEvent (toEnum $ fromIntegral t) (toSurface p)
+    )