[refactor] Wetterhorn -> Montis

3 files changed, 356 insertions, 0 deletions

diff --git a/plug/src/Montis/Foreign/Export.hs b/plug/src/Montis/Foreign/Export.hs
new file mode 100644
index 0000000..f14fb40
--- /dev/null
+++ b/plug/src/Montis/Foreign/Export.hs
@@ -0,0 +1,208 @@
+-- | This module does not export anything. It exists simply to provide C-symbols
+-- for the plugin.
+module Montis.Foreign.Export () where
+
+import Config
+import Control.Arrow (Arrow (first))
+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 Montis.Core.ButtonEvent (ButtonEvent (ButtonEvent), ButtonState (ButtonPressed, ButtonReleased))
+import Montis.Core.KeyEvent (KeyEvent (..), KeyState (..))
+import Montis.Core.SurfaceEvent (SurfaceEvent (SurfaceEvent))
+import Montis.Core.W (W, Montis)
+import qualified Montis.Core.W as W
+import Montis.Foreign.ForeignInterface
+import Montis.Foreign.WlRoots
+
+type Wetter = (W.Config W.WindowLayout, W.State)
+
+toWetter :: (W.Context, W.State) -> (W.Config W.WindowLayout, W.State)
+toWetter = first W.ctxConfig
+
+runForeign :: (Wetter -> W ()) -> Montis -> IO Montis
+runForeign fn stblptr = do
+  w@(ctx, st) <- deRefStablePtr stblptr
+  freeStablePtr stblptr
+  (_, state') <- W.runW (fn $ toWetter w) (ctx, st)
+  newStablePtr (ctx, state')
+
+runForeignWithReturn ::
+  (Storable a) => (Wetter -> W a) -> Ptr a -> Montis -> IO Montis
+runForeignWithReturn fn ptr stableptr = do
+  w@(ctx, st) <- deRefStablePtr stableptr
+  freeStablePtr stableptr
+  (val, state') <- W.runW (fn $ toWetter w) (ctx, st)
+  poke ptr val
+  newStablePtr (ctx, state')
+
+runForeignWithReturn2 ::
+  (Storable a, Storable b) =>
+  (Wetter -> W (a, b)) ->
+  Ptr a ->
+  Ptr b ->
+  Montis ->
+  IO Montis
+runForeignWithReturn2 fn ptrA ptrB stableptr = do
+  w@(ctx, st) <- deRefStablePtr stableptr
+  freeStablePtr stableptr
+  ((vA, vB), state') <- W.runW (fn $ toWetter w) (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 Montis instance.
+foreign export ccall "plugin_hot_start"
+  pluginHotStart ::
+    Ptr CChar -> Word32 -> IO Montis
+
+pluginHotStart :: Ptr CChar -> Word32 -> IO Montis
+pluginHotStart chars len = do
+  bs <- BS.packCStringLen (chars, fromIntegral len)
+  foreignInterface <- getForeignInterface
+  wtr <-
+    newStablePtr
+      ( W.Context foreignInterface config,
+        W.demarshalState config (CH.unpack bs)
+      )
+  runForeign (\(conf, _) -> W.resetHook conf) wtr
+
+-- | 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 Montis
+
+pluginColdStart :: IO Montis
+pluginColdStart = do
+  foreignInterface <- getForeignInterface
+  state <- W.initColdState config
+  wtr <- newStablePtr (W.Context foreignInterface config, state)
+  runForeign (\(conf, _) -> W.resetHook conf) wtr
+
+-- | Marshals the opaque state to a C-style byte array and size pointer.
+foreign export ccall "plugin_marshal_state"
+  pluginMarshalState :: Montis -> Ptr Word32 -> IO (Ptr Word8)
+
+pluginMarshalState :: Montis -> 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_button"
+  pluginHandleButton :: Ptr WlrPointerButtonEvent -> Word32 -> Montis -> IO Montis
+
+pluginHandleButton :: Ptr WlrPointerButtonEvent -> Word32 -> Montis -> IO Montis
+pluginHandleButton eventPtr modifiers = do
+  runForeign $
+    \( _,
+       W.State {W.currentHooks = W.Hooks {buttonHook = buttonHook}}
+       ) -> do
+        event <- W.wio $
+          runForeignDemarshal eventPtr $ do
+            ButtonEvent
+              <$> demarshal
+              <*> demarshal
+              <*> demarshal
+              <*> pure modifiers
+              <*> ( ( \u8 ->
+                        if (u8 :: Word8) == 0
+                          then ButtonReleased
+                          else ButtonPressed
+                    )
+                      <$> demarshal
+                  )
+
+        buttonHook event
+
+foreign export ccall "plugin_handle_keybinding"
+  pluginHandleKeybinding ::
+    Ptr WlrInputDevice ->
+    Ptr WlrEventKeyboardKey ->
+    Word32 ->
+    Word32 ->
+    Word32 ->
+    Ptr CInt ->
+    Montis ->
+    IO Montis
+
+pluginHandleKeybinding ::
+  Ptr WlrInputDevice ->
+  Ptr WlrEventKeyboardKey ->
+  Word32 ->
+  Word32 ->
+  Word32 ->
+  Ptr CInt ->
+  Montis ->
+  IO Montis
+pluginHandleKeybinding inputDevicePtr eventPtr mods sym cp =
+  runForeignWithReturn $
+    \( _,
+       W.State {W.currentHooks = W.Hooks {keyHook = keyHook}}
+       ) -> 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
+        keyHook 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 -> Montis -> IO Montis
+
+pluginHandleSurface :: Ptr WlrXdgSurface -> CInt -> Montis -> IO Montis
+pluginHandleSurface p t =
+  runForeign
+    ( \(_, W.State {currentHooks = W.Hooks {surfaceHook = surfaceHook}}) ->
+        surfaceHook $
+          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 -> Montis -> IO Montis
+
+pluginHandleXWaylandSurface ::
+  Ptr WlrXWaylandSurface -> CInt -> Montis -> IO Montis
+pluginHandleXWaylandSurface p t =
+  runForeign
+    ( \( _,
+         W.State
+           { currentHooks = W.Hooks {surfaceHook = surfaceHook}
+           }
+         ) -> surfaceHook $ SurfaceEvent (toEnum $ fromIntegral t) (toSurface p)
+    )
diff --git a/plug/src/Montis/Foreign/ForeignInterface.hs b/plug/src/Montis/Foreign/ForeignInterface.hs
new file mode 100644
index 0000000..c01e6b8
--- /dev/null
+++ b/plug/src/Montis/Foreign/ForeignInterface.hs
@@ -0,0 +1,81 @@
+module Montis.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 Montis.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/plug/src/Montis/Foreign/WlRoots.hs b/plug/src/Montis/Foreign/WlRoots.hs
new file mode 100644
index 0000000..4b0685f
--- /dev/null
+++ b/plug/src/Montis/Foreign/WlRoots.hs
@@ -0,0 +1,67 @@
+module Montis.Foreign.WlRoots where
+
+import Foreign (IntPtr, Ptr, Word32, intPtrToPtr, ptrToIntPtr, nullPtr)
+import Text.Read
+
+data WlrKeyboard
+
+data WlrPointer
+
+data WlrPointerButtonEvent
+
+data WlrSeat
+
+data WlrInputDevice
+
+data WlrEventKeyboardKey
+
+data WlrXdgSurface
+
+data WlrXWaylandSurface
+
+data Surface
+  = XdgSurface (Ptr WlrXdgSurface)
+  | XWaylandSurface (Ptr WlrXWaylandSurface)
+  deriving (Ord, Eq)
+
+instance Show Surface where
+  show (XdgSurface p) = show (XdgSerializeSurface (ptrToIntPtr p))
+  show (XWaylandSurface p) = show (XWaylandSerializeSurface (ptrToIntPtr p))
+
+instance Read Surface where
+  readPrec = fmap toSurf readPrec
+    where
+      toSurf (XdgSerializeSurface ip) = XdgSurface (intPtrToPtr ip)
+      toSurf (XWaylandSerializeSurface ip) = XWaylandSurface (intPtrToPtr ip)
+
+-- | Type which exists specifically to derive instances of read and show.
+data SerializableSurface
+  = XdgSerializeSurface IntPtr
+  | XWaylandSerializeSurface IntPtr
+  deriving (Read, Show)
+
+class ForeignSurface a where
+  toSurface :: Ptr a -> Surface
+
+instance ForeignSurface WlrXdgSurface where
+  toSurface = XdgSurface
+
+instance ForeignSurface WlrXWaylandSurface where
+  toSurface = XWaylandSurface
+
+guardNull :: Ptr a -> Maybe (Ptr a)
+guardNull p | p == nullPtr = Nothing
+guardNull p = Just p
+
+foreign import ccall "wlr_seat_set_keyboard" wlrSeatSetKeyboard ::
+    Ptr WlrSeat -> Ptr WlrInputDevice -> IO ()
+
+foreign import ccall "wlr_seat_get_keyboard" wlrSeatGetKeyboard ::
+    Ptr WlrSeat -> IO (Ptr WlrKeyboard)
+
+foreign import ccall "wlr_keyboard_get_modifiers" wlrKeyboardGetModifiers ::
+    Ptr WlrKeyboard -> IO Word32
+
+foreign import ccall "wlr_seat_keyboard_notify_key"
+  wlrSeatKeyboardNotifyKey ::
+    Ptr WlrSeat -> Word32 -> Word32 -> Word32 -> IO ()