diff options
Diffstat (limited to 'src/Wetterhorn/Foreign/Export.hs')
| -rw-r--r-- | src/Wetterhorn/Foreign/Export.hs | 156 |
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)) |