From e008ac8d837ad11557c7625f3c311f230986d7f5 Mon Sep 17 00:00:00 2001
From: Josh Rahm <joshuarahm@gmail.com>
Date: Sun, 11 Feb 2024 22:55:00 -0700
Subject: Added event handlers for map/unmap/destroy surfaces, added Alt+F5 for
 hot reload.

It turns out I could actually remove the metaload handler from the
plugin interface. As things turn out, when fully unloading the shared
object and reloading it, the Haskell runtime no longer complained. This
makes things much simpler, which is great.

I do wonder if I'm going to run into issues because of this, but I'll
cross that bridge when it's burning.
---
 src/Main.hs            |  9 ++-------
 src/Wetterhorn/Core.hs | 25 ++++++++++++++++++++-----
 src/Wetterhorn/FFI.hs  | 36 ++++++++++++++++++++++++++++++++++++
 src/harness_adapter.c  |  1 -
 4 files changed, 58 insertions(+), 13 deletions(-)

(limited to 'src')

diff --git a/src/Main.hs b/src/Main.hs
index 75e21bd..03b5018 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -10,13 +10,8 @@ foreign export ccall wetterhorn :: IO Wetterhorn
 
 wetterhorn :: IO Wetterhorn
 wetterhorn =
-  initWetterhorn $
-    WConfig
-      "This is a string"
-      ( \sym -> do
-          wio $
-            printf "Got Key: %x\n" sym
-      )
+  initWetterhorn
+    defaultConfig
 
 main :: IO ()
 main = putStrLn "This should be dynamically linked!\n"
diff --git a/src/Wetterhorn/Core.hs b/src/Wetterhorn/Core.hs
index 7b5690f..7a5c0b1 100644
--- a/src/Wetterhorn/Core.hs
+++ b/src/Wetterhorn/Core.hs
@@ -3,6 +3,7 @@
 module Wetterhorn.Core
   ( WState (..),
     WConfig (..),
+    SurfaceState (..),
     W,
     getWConfig,
     getWState,
@@ -12,6 +13,7 @@ module Wetterhorn.Core
     wio,
     incrementState,
     readWState,
+    defaultConfig,
   )
 where
 
@@ -19,7 +21,9 @@ import Control.Arrow (first)
 import Control.Exception
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as CH
-import Foreign (StablePtr, Word32, newStablePtr)
+import Foreign (Ptr, StablePtr, Word32, newStablePtr, ptrToIntPtr)
+import Numeric (showHex)
+import Text.Printf
 
 -- This is this opaque state presented to the harness.
 type Wetterhorn = StablePtr (WConfig, WState)
@@ -34,11 +38,22 @@ data WState = WState
   }
   deriving (Show, Read)
 
+data SurfaceState = Map | Unmap | Destroy deriving (Eq, Ord, Show, Enum)
+
 data WConfig = WConfig
-  { someConfig :: String,
-    keybindingHandler :: Word32 -> W ()
+  { keybindingHandler :: Word32 -> W (),
+    surfaceHandler :: SurfaceState -> Ptr () -> W ()
   }
 
+defaultConfig :: WConfig
+defaultConfig =
+  WConfig
+    { keybindingHandler = \sym -> do
+          i <- incrementState
+          wio (printf "[%d] Got key yolol %d\n" i sym),
+      surfaceHandler = \state ptr -> wio (printf "Surface %s is %s\n" (showHex (ptrToIntPtr ptr) "") (show state))
+    }
+
 readWState :: ByteString -> IO WState
 readWState bs =
   catch
@@ -73,8 +88,8 @@ getWState = W $ \(_, s) -> pure (s, s)
 runW :: W a -> (WConfig, WState) -> IO (a, WState)
 runW (W fn) = fn
 
-incrementState :: W ()
-incrementState = W $ \(conf, WState s i) -> return ((), WState s (i + 1))
+incrementState :: W Int
+incrementState = W $ \(conf, WState s i) -> return (i, WState s (i + 1))
 
 wio :: IO a -> W a
 wio fn = W $ \(_, b) -> fn >>= \a -> return (a, b)
diff --git a/src/Wetterhorn/FFI.hs b/src/Wetterhorn/FFI.hs
index d941493..1463396 100644
--- a/src/Wetterhorn/FFI.hs
+++ b/src/Wetterhorn/FFI.hs
@@ -25,6 +25,23 @@ runForeign fn stblptr = do
   (_, state') <- runW (fn conf) (conf, st)
   newStablePtr (conf, state')
 
+runForeignWithReturn :: (Storable a) => (WConfig -> W a) -> Ptr a -> Wetterhorn -> IO Wetterhorn
+runForeignWithReturn fn ptr stableptr = do
+  (conf, st) <- deRefStablePtr stableptr
+  freeStablePtr stableptr
+  (val, state') <- runW (fn conf) (conf, st)
+  poke ptr val
+  newStablePtr (conf, state')
+
+runForeignWithReturn2 :: (Storable a, Storable b) => (WConfig -> W (a, b)) -> Ptr a -> Ptr b -> Wetterhorn -> IO Wetterhorn
+runForeignWithReturn2 fn ptrA ptrB stableptr = do
+  (conf, st) <- deRefStablePtr stableptr
+  freeStablePtr stableptr
+  ((vA, vB), state') <- runW (fn conf) (conf, st)
+  poke ptrA vA
+  poke ptrB vB
+  newStablePtr (conf, state')
+
 -- | This function should be defined somewhere in the code. This is kind of like
 -- the "main" function in XMonad.
 foreign import ccall wetterhorn :: IO Wetterhorn
@@ -73,3 +90,22 @@ foreign export ccall "plugin_handle_keybinding"
 
 pluginHandleKeybinding :: Word32 -> Wetterhorn -> IO Wetterhorn
 pluginHandleKeybinding sym = runForeign (`keybindingHandler` sym)
+
+foreign export ccall "plugin_handle_surface_map"
+  pluginHandleSurfaceMap ::
+    Ptr () -> Wetterhorn -> IO Wetterhorn
+pluginHandleSurfaceMap :: Ptr () -> Wetterhorn -> IO Wetterhorn
+pluginHandleSurfaceMap p = runForeign (\c -> surfaceHandler c Map p)
+
+foreign export ccall "plugin_handle_surface_unmap"
+  pluginHandleSurfaceUnmap ::
+    Ptr () -> Wetterhorn -> IO Wetterhorn
+pluginHandleSurfaceUnmap :: Ptr () -> Wetterhorn -> IO Wetterhorn
+pluginHandleSurfaceUnmap p = runForeign (\c -> surfaceHandler c Unmap p)
+
+
+foreign export ccall "plugin_handle_surface_destroy"
+  pluginHandleSurfaceDestroy ::
+    Ptr () -> Wetterhorn -> IO Wetterhorn
+pluginHandleSurfaceDestroy :: Ptr () -> Wetterhorn -> IO Wetterhorn
+pluginHandleSurfaceDestroy p = runForeign (\c -> surfaceHandler c Destroy p)
diff --git a/src/harness_adapter.c b/src/harness_adapter.c
index 82e8caf..5a9b9a4 100644
--- a/src/harness_adapter.c
+++ b/src/harness_adapter.c
@@ -9,5 +9,4 @@
 const char *plugin_name = "Wetterhorn";
 
 void plugin_load(int argc, char **argv) { hs_init(&argc, &argv); }
-void plugin_metaload(int argc, char **argv) { hs_init(&argc, &argv); }
 void plugin_teardown(opqst_t st) { hs_exit(); }
-- 
cgit