3 files changed, 270 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))
diff --git a/src/Wetterhorn/Foreign/ForeignInterface.hs b/src/Wetterhorn/Foreign/ForeignInterface.hs
new file mode 100644
index 0000000..471e3a9
--- /dev/null
+++ b/src/Wetterhorn/Foreign/ForeignInterface.hs
@@ -0,0 +1,81 @@
+module Wetterhorn.Foreign.ForeignInterface
+  ( getForeignInterface,
+    ForeignInterface (..),
+    ForeignDemarshal (..),
+    runForeignDemarshal,
+    demarshal,
+    doShellExec,
+  )
+where
+
+import Control.Monad.State (MonadState (get, put), MonadTrans (lift), StateT, evalStateT)
+import Data.Void (Void)
+import Foreign (Ptr, Storable (peek, sizeOf), castPtr, plusPtr)
+import Foreign.C (CChar, CInt (..))
+import Foreign.C.String
+import GHC.Exts (FunPtr)
+import Wetterhorn.Foreign.WlRoots
+
+newtype ForeignDemarshal a = ForeignDemarshal (StateT (Ptr ()) IO a)
+  deriving (Functor, Monad, Applicative, MonadState (Ptr ()))
+
+runForeignDemarshal :: Ptr b -> ForeignDemarshal a -> IO a
+runForeignDemarshal p (ForeignDemarshal dm) = evalStateT dm (castPtr p)
+
+demarshal :: (Storable a) => ForeignDemarshal a
+demarshal = do
+  ptr <- get
+  val <- ForeignDemarshal $ lift $ peek $ castPtr ptr
+  put (plusPtr ptr (sizeOf val))
+  return val
+
+type CtxT = Ptr Void
+
+type ForeignCallGetPtr = CtxT -> IO (Ptr ())
+
+type ForeignCall = CtxT -> IO ()
+
+type ForeignCallStr = CtxT -> CString -> IO ()
+
+type ForeignCallInt = CtxT -> CInt -> IO ()
+
+foreign import ccall "get_foreign_interface" foreignInterfacePtr :: IO (Ptr ())
+
+foreign import ccall "dynamic" toForeignCall :: FunPtr ForeignCall -> ForeignCall
+
+foreign import ccall "dynamic" toForeignCallStr :: FunPtr ForeignCallStr -> ForeignCallStr
+
+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 (),
+    getSeat :: IO (Ptr WlrSeat)
+  }
+
+doShellExec :: String -> IO ()
+doShellExec str = withCString str shellExec
+
+getForeignInterface :: IO ForeignInterface
+getForeignInterface = do
+  ptr <- foreignInterfacePtr
+  runForeignDemarshal ptr $ do
+    ctx <- demarshal
+    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,
+          getSeat = castPtr <$> toForeignCallGetPtr getSeatFn ctx
+        }
diff --git a/src/Wetterhorn/Foreign/WlRoots.hs b/src/Wetterhorn/Foreign/WlRoots.hs
new file mode 100644
index 0000000..56f2a2c
--- /dev/null
+++ b/src/Wetterhorn/Foreign/WlRoots.hs
@@ -0,0 +1,33 @@
+module Wetterhorn.Foreign.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 ()