aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--package.yaml1
-rw-r--r--src/Internal/Keys.hs36
-rw-r--r--src/Internal/MouseMotion.hs97
-rw-r--r--src/Internal/Submap.hs19
4 files changed, 124 insertions, 29 deletions
diff --git a/package.yaml b/package.yaml
index 7cfb52c..a1f015d 100644
--- a/package.yaml
+++ b/package.yaml
@@ -23,3 +23,4 @@ dependencies:
- transformers
- monad-loops
- data-default
+ - linear
diff --git a/src/Internal/Keys.hs b/src/Internal/Keys.hs
index fcf233e..6d34c4a 100644
--- a/src/Internal/Keys.hs
+++ b/src/Internal/Keys.hs
@@ -46,6 +46,7 @@ import XMonad.Actions.SpawnOn as SpawnOn
import qualified Data.Map as Map
import qualified XMonad.StackSet as W
+import Internal.MouseMotion
import Internal.Windows
import Internal.Lib
import Internal.DMenu
@@ -356,34 +357,8 @@ keymap = runKeys $ do
bind xK_q $
(justMod -|- noMod) $
- let fi = fromIntegral
- mag (fi -> x₁, fi -> y₁) (fi -> x₂, fi -> y₂) =
- sqrt ((x₂ - x₁) ^ 2 + (y₂ - y₁) ^ 2) in
-
- doc "EXPERIMENTAL: Move mouse to control media." $ fix $ \recur -> do
-
- -- Moving the mouse 100+ pixels to the right will go to the next song
- -- Moving the mouse 100+ pixel to the left will go to the prior song
- -- Moving the mouse vertically 100+ pixels will stop the loop
- --
- -- May mess up the mouse, requiring an XMonad reboot, which is why
- -- this is experimental. It's not the most practical bindings in the
- -- world, but it shows that it's theoretically possible to program
- -- some neat mouse moptions to do cool things.
- firstMotion@(x, y) <- nextMotion
- (x', y') <- iterateWhile ((<100) . mag firstMotion) nextMotion
-
-
- if abs (y' - y) > abs (x' - x)
- then
- if (y' - y) < 0
- then logs "up"
- else logs "down"
- else do
- if (x' - x) < 0
- then mediaPrev
- else mediaNext
- recur
+ doc "EXPERIMENTAL: Move mouse to control media." $
+ mouseRotateMotion (logs "CW") (logs "CCW")
bind xK_r $ do
justMod $ doc "Run a command via Rofi" runDMenu
@@ -625,9 +600,12 @@ mouseMap = runButtons $ do
bind button13 $ noMod $ subMouse $ do
bind button1 $ noMod mouseMoveWindow
+ bind button2 $ noMod $ windows . W.sink
bind button3 $ noMod mouseResizeWindow
- bind button13 $ noMod $ windows . W.sink
+ bind button13 $ noMod $ subMouse $ do
+ bind button13 $ noMod $ subMouse $ do
+ bind button13 $ noMod $ noWindow $ spawnX "xsecurelock"
bind button15 $ do
diff --git a/src/Internal/MouseMotion.hs b/src/Internal/MouseMotion.hs
new file mode 100644
index 0000000..c72c824
--- /dev/null
+++ b/src/Internal/MouseMotion.hs
@@ -0,0 +1,97 @@
+{-# LANGUAGE ViewPatterns, BangPatterns #-}
+module Internal.MouseMotion where
+
+import XMonad
+
+import Control.Monad (void, forever)
+import Text.Printf
+import Internal.Submap
+import Control.Monad.Loops (iterateWhile)
+import Control.Monad.Fix (fix)
+import Internal.Logger
+
+import Linear.V2
+import Linear.Metric
+
+data Quadrant = NE | SE | SW | NW deriving (Enum, Show)
+data Direction = CW | CCW deriving (Enum, Show)
+
+getQuadrant :: (Num a, Ord a) => (a, a) -> Quadrant
+getQuadrant (x, y) | x >= 0 && y >= 0 = NE
+getQuadrant (x, y) | x < 0 && y >= 0 = SE
+getQuadrant (x, y) | x < 0 && y < 0 = SW
+getQuadrant (x, y) = NW
+
+
+getDirection :: Quadrant -> Quadrant -> Maybe Direction
+getDirectory a b | a == b = Nothing
+getDirection SW SE = Just CCW
+getDirection SE NE = Just CCW
+getDirection NE NW = Just CCW
+getDirection NW SW = Just CCW
+getDirection _ _ = Just CW
+
+
+liftMouseMotionM :: X a -> MouseMotionM a
+liftMouseMotionM = MouseMotionM . fmap Just
+
+motion :: MouseMotionM (V2 Int)
+motion = MouseMotionM $ do
+ ev <- nextMotionOrButton
+ case ev of
+ Right button -> do
+ logs ("Button " ++ show button)
+ return Nothing
+
+ Left motion -> return (Just $ uncurry V2 motion)
+
+motionSize :: Int -> MouseMotionM (V2 Int)
+motionSize size = do
+ let fsize = fromIntegral size
+
+ !firstmotion <- fmap fromIntegral <$> motion
+
+ let get = do
+ !next <- motion
+ if distance (fmap fromIntegral next) firstmotion >= fsize
+ then return next
+ else get
+
+ get
+
+runMouseMotionM :: MouseMotionM a -> X (Maybe a)
+runMouseMotionM (MouseMotionM a) = a
+
+execMouseMotionM :: MouseMotionM () -> X ()
+execMouseMotionM = void . runMouseMotionM
+
+-- Monad for capturing mouse motion. Terminates and holds Nothing when a
+-- button is pressed.
+newtype MouseMotionM a = MouseMotionM (X (Maybe a))
+
+instance Functor MouseMotionM where
+ fmap fn (MouseMotionM xma) = MouseMotionM (fmap (fmap fn) xma)
+
+instance Applicative MouseMotionM where
+ mf <*> ma = do
+ !f <- mf
+ !a <- ma
+ return (f a)
+
+ pure = return
+
+instance Monad MouseMotionM where
+ return a = MouseMotionM (return (Just a))
+ (MouseMotionM !xa) >>= fn = MouseMotionM $ do
+ !ma <- xa
+ case ma of
+ Just !a ->
+ let (MouseMotionM !xb) = fn a in xb
+ Nothing -> return Nothing
+
+mouseRotateMotion :: X () -> X () -> X ()
+mouseRotateMotion clockWise counterClockwise = execMouseMotionM doMouse
+ where
+ doMouse = forever $ do
+ v <- motion
+ liftMouseMotionM $ logs $ "Motion: " ++ show v
diff --git a/src/Internal/Submap.hs b/src/Internal/Submap.hs
index c51f9b6..32dda2a 100644
--- a/src/Internal/Submap.hs
+++ b/src/Internal/Submap.hs
@@ -3,6 +3,7 @@ module Internal.Submap (
submapButtonsWithKey,
nextButton,
nextMotion,
+ nextMotionOrButton,
module X) where
import XMonad hiding (keys)
@@ -62,6 +63,24 @@ nextMotion = do
return ret
+nextMotionOrButton :: X (Either (Int, Int) (ButtonMask, Button))
+nextMotionOrButton = do
+ XConf { theRoot = root, display = d } <- ask
+ io $ grabPointer d root False (pointerMotionMask .|. buttonPressMask) grabModeAsync grabModeAsync 0 0 currentTime
+
+ ret <- io $ allocaXEvent $ \xEv -> do
+ maskEvent d (pointerMotionMask .|. buttonPressMask) xEv
+ ev <- getEvent xEv
+ case ev of
+ MotionEvent { ev_x = x, ev_y = y } ->
+ return $ Left (fromIntegral x, fromIntegral y)
+ ButtonEvent { ev_button = button, ev_state = m } ->
+ return $ Right (m, button)
+
+ io $ ungrabPointer d currentTime
+
+ return ret
+
submapButtonsWithKey ::
((ButtonMask, Button) -> Window -> X ()) -> Map (ButtonMask, Button) (Window -> X ()) -> Window -> X ()
submapButtonsWithKey defaultAction actions window = do
generated by cgit (git 2.34.1) at 2026-02-22 17:45:21 +0000