better surface handling

3 files changed, 57 insertions, 27 deletions

diff --git a/src/Wetterhorn/Core.hs b/src/Wetterhorn/Core.hs
index b5e4a6f..d3515fc 100644
--- a/src/Wetterhorn/Core.hs
+++ b/src/Wetterhorn/Core.hs
@@ -26,6 +26,7 @@ import Control.Exception
 import Control.Monad (when)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as CH
+import Data.Char (chr, ord)
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Maybe (fromMaybe)
@@ -34,8 +35,7 @@ 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)
+import Wetterhorn.WlRoots
 
 data WContext = WContext
   { ctxForeignInterface :: ForeignInterface,
@@ -88,7 +88,7 @@ data KeyEvent = KeyEvent
 
 data WConfig = WConfig
   { keybindingHandler :: KeyEvent -> W Bool,
-    surfaceHandler :: SurfaceState -> Ptr () -> W ()
+    surfaceHandler :: SurfaceState -> Surface -> W ()
   }
 
 defaultBindings :: Map (KeyState, Word32, Word32) (W ())
@@ -109,7 +109,6 @@ defaultConfig :: WConfig
 defaultConfig =
   WConfig
     { keybindingHandler = \keyEvent -> do
-        i <- incrementState
         seatPtr <- (wio . ForeignInterface.getSeat . ctxForeignInterface) =<< getWContext
 
         maybe
@@ -130,7 +129,7 @@ defaultConfig =
           $ Map.lookup
             (state keyEvent, modifiers keyEvent, keysym keyEvent)
             defaultBindings,
-      surfaceHandler = \state ptr -> wio (printf "Surface %s is %s\n" (showHex (ptrToIntPtr ptr) "") (show state))
+      surfaceHandler = \state surface -> wio (printf "Surface %s is %s\n" (show surface) (show state))
     }
 
 readWState :: ByteString -> IO WState
diff --git a/src/Wetterhorn/FFI.hs b/src/Wetterhorn/FFI.hs
index 4be7189..6173291 100644
--- a/src/Wetterhorn/FFI.hs
+++ b/src/Wetterhorn/FFI.hs
@@ -17,10 +17,9 @@ import Foreign
     newStablePtr,
   )
 import Foreign.C (CChar, CInt (..))
-import System.Posix.Types (CIno)
 import Wetterhorn.Core
 import Wetterhorn.Core.ForeignInterface
-import Wetterhorn.WlRoots (WlrEventKeyboardKey, WlrInputDevice)
+import Wetterhorn.WlRoots
 
 runForeign :: (WConfig -> W ()) -> Wetterhorn -> IO Wetterhorn
 runForeign fn stblptr = do
@@ -123,23 +122,22 @@ pluginHandleKeybinding inputDevicePtr eventPtr mods sym cp =
             inputDevicePtr
     (\b -> if b then 1 else 0) <$> keybindingHandler config event
 
-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)
+-- | Function exported to the harness to handle the mapping/unmapping/deletion
+-- of an XDG surface.
+foreign export ccall "plugin_handle_surface"
+  pluginHandleSurface ::
+    Ptr WlrXdgSurface -> CInt -> Wetterhorn -> IO Wetterhorn
+
+pluginHandleSurface :: Ptr WlrXdgSurface -> CInt -> Wetterhorn -> IO Wetterhorn
+pluginHandleSurface p t =
+  runForeign (\c -> surfaceHandler c (toEnum $ fromIntegral t) (toSurface p))
+
+-- | Function exported to the harness to handle the mapping/unmapping/deletion
+-- of an XWayland surface.
+foreign export ccall "plugin_handle_xwayland_surface"
+  pluginHandleXWaylandSurface ::
+    Ptr WlrXWaylandSurface -> CInt -> Wetterhorn -> IO Wetterhorn
+
+pluginHandleXWaylandSurface :: Ptr WlrXWaylandSurface -> CInt -> Wetterhorn -> IO Wetterhorn
+pluginHandleXWaylandSurface p t =
+  runForeign (\c -> surfaceHandler c (toEnum $ fromIntegral t) (toSurface p))
diff --git a/src/Wetterhorn/WlRoots.hs b/src/Wetterhorn/WlRoots.hs
new file mode 100644
index 0000000..7a2a237
--- /dev/null
+++ b/src/Wetterhorn/WlRoots.hs
@@ -0,0 +1,33 @@
+module Wetterhorn.WlRoots where
+
+import Foreign (Ptr, Word32)
+
+data WlrSeat
+
+data WlrInputDevice
+
+data WlrEventKeyboardKey
+
+data WlrXdgSurface
+
+data WlrXWaylandSurface
+
+data Surface
+  = XdgSurface (Ptr WlrXdgSurface)
+  | XWaylandSurface (Ptr WlrXWaylandSurface)
+  deriving (Show, Ord, Eq)
+
+class ForeignSurface a where
+  toSurface :: Ptr a -> Surface
+
+instance ForeignSurface WlrXdgSurface where
+  toSurface = XdgSurface
+
+instance ForeignSurface WlrXWaylandSurface where
+  toSurface = XWaylandSurface
+
+foreign import ccall "wlr_seat_set_keyboard" wlrSeatSetKeyboard :: Ptr WlrSeat -> Ptr WlrInputDevice -> IO ()
+
+foreign import ccall "wlr_seat_keyboard_notify_key"
+  wlrSeatKeyboardNotifyKey ::
+    Ptr WlrSeat -> Word32 -> Word32 -> Word32 -> IO ()