6 files changed, 64 insertions, 4 deletions
diff --git a/plug/src/Montis/Base/Foreign/WlRoots/Types.hs b/plug/src/Montis/Base/Foreign/WlRoots/Types.hs
index 51762d5..c109653 100644
--- a/plug/src/Montis/Base/Foreign/WlRoots/Types.hs
+++ b/plug/src/Montis/Base/Foreign/WlRoots/Types.hs
@@ -24,6 +24,20 @@ newtype WlrPointerButtonEvent where
   WlrPointerButtonEvent :: Ptr ForeignWlrPointerButtonEvent -> WlrPointerButtonEvent
   deriving (Show, Ord, Eq)
 
+-- | Opaque foreign type for wlroots pointer motion events.
+data ForeignWlrPointerMotionEvent
+
+newtype WlrPointerMotionEvent where
+  WlrPointerMotionEvent :: Ptr ForeignWlrPointerMotionEvent -> WlrPointerMotionEvent
+  deriving (Show, Ord, Eq)
+
+-- | Opaque foreign type for wlroots absolute pointer motion events.
+data ForeignWlrPointerMotionAbsoluteEvent
+
+newtype WlrPointerMotionAbsoluteEvent where
+  WlrPointerMotionAbsoluteEvent :: Ptr ForeignWlrPointerMotionAbsoluteEvent -> WlrPointerMotionAbsoluteEvent
+  deriving (Show, Ord, Eq)
+
 -- | Opaque foreign type for a wlroots seat.
 data ForeignWlrSeat
 
diff --git a/plug/src/Montis/Core/Events.hs b/plug/src/Montis/Core/Events.hs
index 8c0742e..cb74d6f 100644
--- a/plug/src/Montis/Core/Events.hs
+++ b/plug/src/Montis/Core/Events.hs
@@ -27,6 +27,14 @@ data ButtonEvent = ButtonEvent
   }
   deriving (Eq, Show, Ord)
 
+data MotionEvent = MotionEvent
+  { motionEvent_pointer :: WlrPointer,
+    motionEvent_timeMs :: Word32,
+    motionEvent_modifiers :: Word32,
+    motionEvent_absolute :: (Double, Double)
+  }
+  deriving (Eq, Show, Ord)
+
 data SurfaceState = Map | Unmap | Destroy
   deriving (Eq, Ord, Show, Read, Enum)
 
diff --git a/plug/src/Montis/Core/Internal/Foreign/Export.hs b/plug/src/Montis/Core/Internal/Foreign/Export.hs
index c3ab71f..a418ae8 100644
--- a/plug/src/Montis/Core/Internal/Foreign/Export.hs
+++ b/plug/src/Montis/Core/Internal/Foreign/Export.hs
@@ -18,7 +18,20 @@ import Foreign
     newStablePtr,
   )
 import Foreign.C (CChar, CInt (..))
-import Montis.Base.Foreign.WlRoots.Types (ForeignSurface (toSurface), ForeignWlrInputDevice, ForeignWlrPointer, ForeignWlrXWaylandSurface, ForeignWlrXdgSurface, WlrEventKeyboardKey, WlrInputDevice (WlrInputDevice), WlrPointer (WlrPointer), WlrPointerButtonEvent)
+import Foreign.Ptr (castPtr)
+import Montis.Base.Foreign.WlRoots.Types
+  ( ForeignSurface (toSurface),
+    ForeignWlrInputDevice,
+    ForeignWlrPointer,
+    ForeignWlrPointerMotionAbsoluteEvent,
+    ForeignWlrXWaylandSurface,
+    ForeignWlrXdgSurface,
+    WlrEventKeyboardKey,
+    WlrInputDevice (WlrInputDevice),
+    WlrPointer (WlrPointer),
+    WlrPointerButtonEvent,
+    WlrPointerMotionAbsoluteEvent,
+  )
 import Montis.Core
 import Montis.Core.State
 import Montis.Core.State.Marshal (marshalState)
@@ -126,6 +139,29 @@ pluginHandleKeybinding inputDevicePtr eventPtr mods sym cp =
     keyHook s event
     return 1
 
+foreign export ccall "plugin_handle_motion"
+  pluginHandleMotion :: Ptr WlrPointerMotionAbsoluteEvent -> Word32 -> OpqStT -> IO OpqStT
+
+pluginHandleMotion :: Ptr WlrPointerMotionAbsoluteEvent -> Word32 -> OpqStT -> IO OpqStT
+pluginHandleMotion eventPtr modifiers =
+  runForeign $ do
+    s <- gets currentHooks
+    event <- liftIO $
+      runDemarshal (castPtr eventPtr) $ do
+        pointerPtr <- demarshal :: Demarshal (Ptr ForeignWlrPointer)
+        tMs <- demarshal
+        _ <- demarshal :: Demarshal Word32
+        x <- demarshal
+        y <- demarshal
+        return $
+          MotionEvent
+            (WlrPointer pointerPtr)
+            tMs
+            modifiers
+            (x, y)
+
+    motionHook s event
+
 -- | 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 a2da111..1124466 100644
--- a/plug/src/Montis/Core/Monad.hs
+++ b/plug/src/Montis/Core/Monad.hs
@@ -58,7 +58,8 @@ defaultConfig =
         Hooks
           { keyHook = liftIO . print,
             surfaceHook = liftIO . print,
-            buttonHook = liftIO . print
+            buttonHook = liftIO . print,
+            motionHook = liftIO . print
           },
       -- Default hooks are no-ops except for basic printing, which makes the
       -- system usable without extra wiring during development.
diff --git a/plug/src/Montis/Core/State.hs b/plug/src/Montis/Core/State.hs
index 303830b..899846a 100644
--- a/plug/src/Montis/Core/State.hs
+++ b/plug/src/Montis/Core/State.hs
@@ -43,7 +43,8 @@ data Hooks m where
   Hooks ::
     { keyHook :: KeyEvent -> m (),
       surfaceHook :: SurfaceEvent -> m (),
-      buttonHook :: ButtonEvent -> m ()
+      buttonHook :: ButtonEvent -> m (),
+      motionHook :: MotionEvent -> m ()
     } ->
     Hooks m
 
diff --git a/plug/src/Montis/Foreign/Marshal.hs b/plug/src/Montis/Foreign/Marshal.hs
index ed7b006..157d928 100644
--- a/plug/src/Montis/Foreign/Marshal.hs
+++ b/plug/src/Montis/Foreign/Marshal.hs
@@ -2,7 +2,7 @@ module Montis.Foreign.Marshal where
 
 import Control.Monad.State
 import Data.Word
-import Foreign (Ptr, Storable (sizeOf, peek), castPtr, plusPtr)
+import Foreign (Ptr, Storable (peek, sizeOf), castPtr, plusPtr)
 
 type Offset = Word32