[feat] add focusing and better dragging.

4 files changed, 172 insertions, 88 deletions

diff --git a/plug/src/Config.hs b/plug/src/Config.hs
index 7314604..fd337eb 100644
--- a/plug/src/Config.hs
+++ b/plug/src/Config.hs
@@ -2,17 +2,10 @@ module Config () where
 
 import Control.Monad.IO.Class (liftIO)
 import Data.Bits (shiftL, (.&.))
-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
+import Montis.Standard.Drag (DragConfig (DragConfig))
+import Montis.Standard.Mouse (MouseConfig (MouseConfig))
 import Montis.Standard.Keys (KeysConfig (KeysConfig), subkeys)
 
 foreign export ccall "plugin_cold_start"
@@ -45,82 +38,6 @@ mod1Mask = 1 `shiftL` 3 -- WLR_MODIFIER_ALT
 
 config :: MontisConfig
 config =
-  install (KeysConfig keys) $
-    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
-
-newtype CursorPosition = CursorPosition (Double, Double)
-  deriving (Typeable)
-
-instance StateExtension CursorPosition where
-  initialValue = CursorPosition (0, 0)
-  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
-      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))
+  install MouseConfig $
+    install (DragConfig mod1Mask) $
+      install (KeysConfig keys) defaultConfig
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