[feat] can move the window around.

5 files changed, 134 insertions, 2 deletions

diff --git a/plug/src/Config.hs b/plug/src/Config.hs
index 0904ded..e80f360 100644
--- a/plug/src/Config.hs
+++ b/plug/src/Config.hs
@@ -1,5 +1,16 @@
 module Config () where
 
+import Control.Monad.IO.Class (liftIO)
+import Data.Maybe (fromMaybe)
+import Data.Typeable (Typeable)
+import Data.Void (Void)
+import Data.Word (Word32)
+import Foreign (Ptr)
+import Foreign.C (CDouble)
+import Foreign.Marshal.Alloc (alloca)
+import Foreign.Ptr (nullPtr)
+import Foreign.Storable (peek)
+import Montis.Base.Foreign.Runtime
 import Montis.Core
 
 foreign export ccall "plugin_cold_start"
@@ -15,4 +26,82 @@ hotStart :: MontisHotStart
 hotStart = hotStartMontis config
 
 config :: MontisConfig
-config = defaultConfig
+config =
+  defaultConfig
+    { startingHooks =
+        (startingHooks defaultConfig)
+          { buttonHook = onButton,
+            motionHook = onMotion
+          }
+    }
+
+data DragState = DragState
+  { dragToplevel :: Ptr ForeignMontisToplevel,
+    dragOffsetX :: Double,
+    dragOffsetY :: Double
+  }
+  deriving (Typeable)
+
+newtype Dragging = Dragging (Maybe DragState)
+  deriving (Typeable)
+
+instance StateExtension Dragging where
+  initialValue = Dragging Nothing
+  marshalExtension _ = Nothing
+  demarshalExtension _ = Nothing
+
+leftButton :: Word32
+leftButton = 272 -- BTN_LEFT
+
+onButton :: ButtonEvent -> Montis ()
+onButton ev
+  | buttonEvent_button ev /= leftButton = return ()
+  | buttonEvent_state ev == ButtonPressed = do
+      self <- getSelfPtr
+      newDrag <- liftIO $ do
+        (x, y) <- getCursorPosition self
+        tl <- foreign_toplevelAt (unwrapSelf self) (realToFrac x) (realToFrac y)
+        if tl == nullPtr
+          then return (Dragging Nothing)
+          else do
+            (tx, ty) <- getToplevelPosition tl
+            return $
+              Dragging
+                (Just (DragState tl (x - tx) (y - ty)))
+      xStatePut newDrag
+  | buttonEvent_state ev == ButtonReleased =
+      xStatePut (Dragging Nothing)
+  | otherwise = return ()
+
+onMotion :: MotionEvent -> Montis ()
+onMotion _ev = do
+  Dragging mdrag <- fromMaybe (Dragging Nothing) <$> xStateGet
+  case mdrag of
+    Nothing -> return ()
+    Just (DragState tl dx dy) -> do
+      self <- getSelfPtr
+      (x, y) <- liftIO $ getCursorPosition self
+      liftIO $
+        foreign_setToplevelPosition
+          tl
+          (realToFrac (x - dx))
+          (realToFrac (y - dy))
+
+unwrapSelf :: SelfPtr -> Ptr Void
+unwrapSelf (SelfPtr p) = p
+
+getCursorPosition :: SelfPtr -> IO (Double, Double)
+getCursorPosition self =
+  alloca $ \xPtr -> alloca $ \yPtr -> do
+    foreign_getCursorPosition (unwrapSelf self) xPtr yPtr
+    x <- peek xPtr
+    y <- peek yPtr
+    return (realToFrac (x :: CDouble), realToFrac (y :: CDouble))
+
+getToplevelPosition :: Ptr ForeignMontisToplevel -> IO (Double, Double)
+getToplevelPosition tl =
+  alloca $ \xPtr -> alloca $ \yPtr -> do
+    foreign_getToplevelPosition tl xPtr yPtr
+    x <- peek xPtr
+    y <- peek yPtr
+    return (realToFrac (x :: CDouble), realToFrac (y :: CDouble))
diff --git a/plug/src/Montis/Base/Foreign/Runtime.hs b/plug/src/Montis/Base/Foreign/Runtime.hs
index c43471e..5c131f3 100644
--- a/plug/src/Montis/Base/Foreign/Runtime.hs
+++ b/plug/src/Montis/Base/Foreign/Runtime.hs
@@ -1,9 +1,11 @@
 module Montis.Base.Foreign.Runtime where
 
 import Data.Void
-import Foreign.C (CInt (..), CString)
+import Foreign.C (CInt (..), CString, CDouble (..))
 import Foreign.Ptr
 
+data ForeignMontisToplevel
+
 foreign import ccall "montis_do_request_hot_reload" foreign_doRequestHotReload :: Ptr Void -> IO ()
 
 foreign import ccall "montis_do_request_log" foreign_doRequestLog :: Ptr Void -> CString -> IO ()
@@ -11,3 +13,15 @@ foreign import ccall "montis_do_request_log" foreign_doRequestLog :: Ptr Void ->
 foreign import ccall "montis_do_request_exit" foreign_doRequestExit :: Ptr Void -> CInt -> IO ()
 
 foreign import ccall "montis_plugin_get_seat" foreign_getSeat :: Ptr Void -> IO (Ptr Void)
+
+foreign import ccall "montis_plugin_get_cursor_position"
+  foreign_getCursorPosition :: Ptr Void -> Ptr CDouble -> Ptr CDouble -> IO ()
+
+foreign import ccall "montis_plugin_toplevel_at"
+  foreign_toplevelAt :: Ptr Void -> CDouble -> CDouble -> IO (Ptr ForeignMontisToplevel)
+
+foreign import ccall "montis_plugin_get_toplevel_position"
+  foreign_getToplevelPosition :: Ptr ForeignMontisToplevel -> Ptr CDouble -> Ptr CDouble -> IO ()
+
+foreign import ccall "montis_plugin_set_toplevel_position"
+  foreign_setToplevelPosition :: Ptr ForeignMontisToplevel -> CDouble -> CDouble -> IO ()
diff --git a/plug/src/Montis/Core/Internal/Foreign/Export.hs b/plug/src/Montis/Core/Internal/Foreign/Export.hs
index a418ae8..99ba58b 100644
--- a/plug/src/Montis/Core/Internal/Foreign/Export.hs
+++ b/plug/src/Montis/Core/Internal/Foreign/Export.hs
@@ -37,6 +37,8 @@ import Montis.Core.State
 import Montis.Core.State.Marshal (marshalState)
 import Montis.Foreign.Marshal (Demarshal (Demarshal), demarshal, runDemarshal)
 
+-- | Helpers to unpack the opaque state, run a Montis action, and re-wrap it.
+--   Each call consumes the old stable pointer and returns a fresh one.
 runForeign ::
   Montis () ->
   OpqStT ->
@@ -60,6 +62,9 @@ runForeignWithReturn fn outptr stableptr = do
   poke outptr val
   newStablePtr (ctx, state')
 
+-- ----------------------------------------------------------------------
+-- State marshal/export
+
 -- | Marshals the opaque state to a C-style byte array and size pointer.
 foreign export ccall "plugin_marshal_state"
   pluginMarshalState :: OpqStT -> Ptr Word32 -> IO (Ptr Word8)
@@ -74,6 +79,9 @@ pluginMarshalState opqStT outlen = do
     pokeByteOff ret off w8
   return ret
 
+-- ----------------------------------------------------------------------
+-- Input handlers
+
 foreign export ccall "plugin_handle_button"
   pluginHandleButton :: Ptr WlrPointerButtonEvent -> Word32 -> OpqStT -> IO OpqStT
 
@@ -83,6 +91,7 @@ pluginHandleButton eventPtr modifiers =
     s <- gets currentHooks
     event <- liftIO $
       runDemarshal eventPtr $ do
+        -- Follows struct wlr_pointer_button_event field order.
         pointerPtr <- demarshal :: Demarshal (Ptr ForeignWlrPointer)
         tMs <- demarshal
         button <- demarshal
@@ -97,6 +106,9 @@ pluginHandleButton eventPtr modifiers =
 
     buttonHook s event
 
+-- ----------------------------------------------------------------------
+-- Keybinding handler
+
 foreign export ccall "plugin_handle_keybinding"
   pluginHandleKeybinding ::
     Ptr ForeignWlrInputDevice ->
@@ -122,6 +134,7 @@ pluginHandleKeybinding inputDevicePtr eventPtr mods sym cp =
     s <- gets currentHooks
     event <- liftIO $
       runDemarshal eventPtr $ do
+        -- Matches struct wlr_keyboard_key_event in wlroots.
         tMs <- demarshal
         kc <- demarshal
         _ <- (demarshal :: Demarshal Word32)
@@ -139,6 +152,9 @@ pluginHandleKeybinding inputDevicePtr eventPtr mods sym cp =
     keyHook s event
     return 1
 
+-- ----------------------------------------------------------------------
+-- Motion handler
+
 foreign export ccall "plugin_handle_motion"
   pluginHandleMotion :: Ptr WlrPointerMotionAbsoluteEvent -> Word32 -> OpqStT -> IO OpqStT
 
@@ -148,6 +164,7 @@ pluginHandleMotion eventPtr modifiers =
     s <- gets currentHooks
     event <- liftIO $
       runDemarshal (castPtr eventPtr) $ do
+        -- After time_msec, wlroots pads to 8-byte alignment for doubles.
         pointerPtr <- demarshal :: Demarshal (Ptr ForeignWlrPointer)
         tMs <- demarshal
         _ <- demarshal :: Demarshal Word32
@@ -162,6 +179,9 @@ pluginHandleMotion eventPtr modifiers =
 
     motionHook s event
 
+-- ----------------------------------------------------------------------
+-- Surface handlers
+
 -- | Function exported to the harness to handle the mapping/unmapping/deletion
 -- of an XDG surface.
 foreign export ccall "plugin_handle_surface"
diff --git a/plug/src/Montis/Core/Monad.hs b/plug/src/Montis/Core/Monad.hs
index 1124466..06bfc28 100644
--- a/plug/src/Montis/Core/Monad.hs
+++ b/plug/src/Montis/Core/Monad.hs
@@ -45,6 +45,10 @@ instance MonadReader MontisConfig Montis where
   local cfn (Montis fn) =
     Montis $ local (\ctx -> ctx {ctxConfig = cfn (ctxConfig ctx)}) fn
 
+-- | Access the plugin self pointer stored in the context.
+getSelfPtr :: Montis SelfPtr
+getSelfPtr = Montis $ asks ctxSelfPtr
+
 -- | Run a Montis action with a fixed context and initial state, returning the
 --   result value and the updated state.
 runMontis :: MontisContext -> MontisState -> Montis a -> IO (a, MontisState)
diff --git a/plug/src/Montis/Core/State/Marshal.hs b/plug/src/Montis/Core/State/Marshal.hs
index 642201e..04a2a57 100644
--- a/plug/src/Montis/Core/State/Marshal.hs
+++ b/plug/src/Montis/Core/State/Marshal.hs
@@ -14,6 +14,8 @@ data MarshalledState where
 -- | Marshals the serializable parts of the state to a string. This happens
 -- during a hot-reload where some state must be saved to persist across hot
 -- reloads.
+-- Only the extensible state is persisted; hooks and other runtime data are
+-- reconstructed from the config on restart.
 marshalState :: State m -> String
 marshalState
   ( State
@@ -24,12 +26,15 @@ marshalState
       MarshalledState
         (mapMaybe (\(k, v) -> (extensionKeyValue k,) <$> doMarshalEx v) (M.toList xs))
     where
+      -- Left values are already marshalled; Right values are re-encoded here.
       doMarshalEx :: Either String (Extension StateExtension) -> Maybe String
       doMarshalEx (Left s) = Just s
       doMarshalEx (Right (Extension a)) = marshalExtension a
 
 -- | Demarshals the string from "marshalState" into a state. Uses the provided
 -- config to fill out non-persistent parts of the state.
+-- The extensible map is rehydrated as marshalled strings so decoding can be
+-- deferred until a specific extension is requested.
 demarshalState :: Config m -> String -> State m
 demarshalState Config {startingHooks = hooks} str =
   State hooks xs