[feat] add focusing and better dragging.

3 files changed, 167 insertions, 0 deletions

diff --git a/plug/src/Montis/Base/Foreign/Runtime.hs b/plug/src/Montis/Base/Foreign/Runtime.hs
index 5797aa5..65ae53f 100644
--- a/plug/src/Montis/Base/Foreign/Runtime.hs
+++ b/plug/src/Montis/Base/Foreign/Runtime.hs
@@ -22,3 +22,6 @@ foreign import ccall "montis_plugin_get_toplevel_position"
 
 foreign import ccall "montis_plugin_set_toplevel_position"
   foreign_setToplevelPosition :: Ptr ForeignMontisToplevel -> CDouble -> CDouble -> IO ()
+
+foreign import ccall "montis_plugin_focus_toplevel"
+  foreign_focusToplevel :: Ptr ForeignMontisToplevel -> IO ()
diff --git a/plug/src/Montis/Standard/Drag.hs b/plug/src/Montis/Standard/Drag.hs
new file mode 100644
index 0000000..192ade8
--- /dev/null
+++ b/plug/src/Montis/Standard/Drag.hs
@@ -0,0 +1,106 @@
+module Montis.Standard.Drag where
+
+import Control.Monad.IO.Class (liftIO)
+import Data.Bits ((.&.))
+import Data.Data (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
+import Montis.Core.State
+  ( Config (startingHooks),
+    ConfigModule (..),
+    Hooks (buttonHook, motionHook),
+    StateExtension (..),
+  )
+import Montis.Standard.Mouse (CursorPosition (CursorPosition))
+
+data DragConfig where
+  DragConfig ::
+    { dragModifierMask :: Word32
+    } ->
+    DragConfig
+  deriving (Typeable)
+
+instance ConfigModule Montis DragConfig where
+  alterConfig cfg c =
+    let ohb = buttonHook (startingHooks c)
+        ohm = motionHook (startingHooks c)
+     in c
+          { startingHooks =
+              (startingHooks c)
+                { buttonHook = \ev -> onButton (dragModifierMask cfg) ev >> ohb ev,
+                  motionHook = \ev -> onMotion ev >> ohm ev
+                }
+          }
+
+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 :: Word32 -> ButtonEvent -> Montis ()
+onButton modMask ev
+  | buttonEvent_button ev /= leftButton = return ()
+  | buttonEvent_state ev == ButtonPressed = do
+      if buttonEvent_modifiers ev .&. modMask == 0
+        then return ()
+        else do
+          self <- getSelfPtr
+          CursorPosition (x, y) <- xStateGet
+          newDrag <- liftIO $ do
+            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
+  let (x, y) = motionEvent_absolute ev
+  xStatePut (CursorPosition (x, y))
+  Dragging mdrag <- xStateGet
+  case mdrag of
+    Nothing -> return ()
+    Just (DragState tl dx dy) -> do
+      liftIO $
+        foreign_setToplevelPosition
+          tl
+          (realToFrac (x - dx))
+          (realToFrac (y - dy))
+
+unwrapSelf :: SelfPtr -> Ptr Void
+unwrapSelf (SelfPtr p) = p
+
+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/Standard/Mouse.hs b/plug/src/Montis/Standard/Mouse.hs
new file mode 100644
index 0000000..b671206
--- /dev/null
+++ b/plug/src/Montis/Standard/Mouse.hs
@@ -0,0 +1,58 @@
+module Montis.Standard.Mouse where
+
+import Control.Monad.IO.Class (liftIO)
+import Data.Data (Typeable)
+import Data.Void (Void)
+import Foreign.Ptr (Ptr, nullPtr)
+import Montis.Base.Foreign.Runtime (foreign_focusToplevel, foreign_toplevelAt)
+import Montis.Core
+import Montis.Core.State
+  ( Config (startingHooks),
+    ConfigModule (..),
+    Hooks (buttonHook, motionHook),
+    StateExtension (..),
+  )
+
+data MouseConfig where
+  MouseConfig :: MouseConfig
+  deriving (Typeable)
+
+instance ConfigModule Montis MouseConfig where
+  alterConfig _ c =
+    let ohb = buttonHook (startingHooks c)
+        ohm = motionHook (startingHooks c)
+     in c
+          { startingHooks =
+              (startingHooks c)
+                { buttonHook = \ev -> onButton ev >> ohb ev,
+                  motionHook = \ev -> onMotion ev >> ohm ev
+                }
+          }
+
+newtype CursorPosition = CursorPosition (Double, Double)
+  deriving (Typeable)
+
+instance StateExtension CursorPosition where
+  initialValue = CursorPosition (0, 0)
+  marshalExtension _ = Nothing
+  demarshalExtension _ = Nothing
+
+onMotion :: MotionEvent -> Montis ()
+onMotion ev = do
+  let (x, y) = motionEvent_absolute ev
+  xStatePut (CursorPosition (x, y))
+
+onButton :: ButtonEvent -> Montis ()
+onButton ev
+  | buttonEvent_state ev /= ButtonPressed = return ()
+  | otherwise = do
+      self <- getSelfPtr
+      CursorPosition (x, y) <- xStateGet
+      liftIO $ do
+        tl <- foreign_toplevelAt (unwrapSelf self) (realToFrac x) (realToFrac y)
+        if tl == nullPtr
+          then return ()
+          else foreign_focusToplevel tl
+
+unwrapSelf :: SelfPtr -> Ptr Void
+unwrapSelf (SelfPtr p) = p