Huge refactor for the Haskell code.HEADmain

This adds new layout configuration, preparing for actually using the
layouts. This also restructures the code and tries to keep code
interfacing with the foreign structures together and rename them to more
sensible names.

1 files changed, 156 insertions, 0 deletions

diff --git a/src/Wetterhorn/Foreign/Export.hs b/src/Wetterhorn/Foreign/Export.hs
new file mode 100644
index 0000000..0d71a4e
--- /dev/null
+++ b/src/Wetterhorn/Foreign/Export.hs
@@ -0,0 +1,156 @@
+-- | This module does not export anything. It exists simply to provide C-symbols
+-- for the plugin.
+module Wetterhorn.Foreign.Export () where
+
+import Config
+import Control.Monad (forM_)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as CH
+import Foreign
+  ( Ptr,
+    Storable (poke, pokeByteOff),
+    Word32,
+    Word8,
+    deRefStablePtr,
+    freeStablePtr,
+    mallocBytes,
+    newStablePtr,
+  )
+import Foreign.C (CChar, CInt (..))
+import Wetterhorn.Core.KeyEvent (KeyEvent (..), KeyState (..))
+import Wetterhorn.Core.SurfaceEvent (SurfaceEvent (SurfaceEvent))
+import Wetterhorn.Core.W (W, Wetterhorn)
+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
+runForeign fn stblptr = do
+  (ctx, st) <- deRefStablePtr stblptr
+  freeStablePtr stblptr
+  (_, state') <- W.runW (fn $ W.ctxConfig ctx) (ctx, st)
+  newStablePtr (ctx, state')
+
+runForeignWithReturn :: (Storable a) => (forall l. W.Config l -> W a) -> Ptr a -> Wetterhorn -> IO Wetterhorn
+runForeignWithReturn fn ptr stableptr = do
+  (ctx, st) <- deRefStablePtr stableptr
+  freeStablePtr stableptr
+  (val, state') <- W.runW (fn $ W.ctxConfig ctx) (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 fn ptrA ptrB stableptr = do
+  (ctx, st) <- deRefStablePtr stableptr
+  freeStablePtr stableptr
+  ((vA, vB), state') <- W.runW (fn $ W.ctxConfig ctx) (ctx, st)
+  poke ptrA vA
+  poke ptrB vB
+  newStablePtr (ctx, state')
+
+-- | This function is the implementation of the "hotstart" mechanism. It gives a
+-- pointer to the previously marshalled state and the length of that array and
+-- this function returns a Wetterhorn instance.
+foreign export ccall "plugin_hot_start"
+  pluginHotStart ::
+    Ptr CChar -> Word32 -> IO Wetterhorn
+
+pluginHotStart :: Ptr CChar -> Word32 -> IO Wetterhorn
+pluginHotStart chars len = do
+  bs <- BS.packCStringLen (chars, fromIntegral len)
+  foreignInterface <- getForeignInterface
+  newStablePtr
+    ( W.Context foreignInterface config,
+      W.demarshalState (W.layout config) (CH.unpack bs)
+    )
+
+-- | This function is called when a "coldstart" request is receieved. It just
+-- calles the function "wetterhorn". This function should be defined in the main
+-- code as it's sort-of the equivalent of XMonad's "main" function.
+foreign export ccall "plugin_cold_start"
+  pluginColdStart :: IO Wetterhorn
+
+pluginColdStart :: IO Wetterhorn
+pluginColdStart = do
+  foreignInterface <- getForeignInterface
+  state <- W.initColdState (W.layout config)
+  newStablePtr (W.Context foreignInterface config, state)
+
+-- | Marshals the opaque state to a C-style byte array and size pointer.
+foreign export ccall "plugin_marshal_state"
+  pluginMarshalState :: Wetterhorn -> Ptr Word32 -> IO (Ptr Word8)
+
+pluginMarshalState :: Wetterhorn -> Ptr Word32 -> IO (Ptr Word8)
+pluginMarshalState stblptr outlen = do
+  (_, st) <- deRefStablePtr stblptr
+  let bs = CH.pack (W.marshalState st)
+  ret <- mallocBytes (BS.length bs)
+  poke outlen (fromIntegral $ BS.length bs)
+  forM_ (zip [0 ..] (BS.unpack bs)) $ \(off, w8) -> do
+    pokeByteOff ret off w8
+  return ret
+
+foreign export ccall "plugin_handle_keybinding"
+  pluginHandleKeybinding ::
+    Ptr WlrInputDevice ->
+    Ptr WlrEventKeyboardKey ->
+    Word32 ->
+    Word32 ->
+    Word32 ->
+    Ptr CInt ->
+    Wetterhorn ->
+    IO Wetterhorn
+
+pluginHandleKeybinding ::
+  Ptr WlrInputDevice ->
+  Ptr WlrEventKeyboardKey ->
+  Word32 ->
+  Word32 ->
+  Word32 ->
+  Ptr CInt ->
+  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
+
+-- | 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 ->
+        W.surfaceHook
+          c
+          $ SurfaceEvent (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 -> W.surfaceHook c $ SurfaceEvent (toEnum $ fromIntegral t) (toSurface p))