From 8691c81c05b16e31644c0c373652f7056f0c2d17 Mon Sep 17 00:00:00 2001 From: Lukas Mai Date: Fri, 29 Feb 2008 01:21:36 +0100 Subject: XMonad.Actions.MouseGestures: refactoring, code simplification It is now possible to get "live" status updates while the gesture handler is running. I use this in my xmonad.hs to print the current gesture to my status bar. Because collecting movements is now the callback's job, the implementation of mouseGestureH got quite a bit simpler. The interface is incompatible with the previous mouseGestureH but the old mouseGesture function works as before. darcs-hash:20080229002136-462cf-0afb81828e5cc56330652d834d5e011057b7405f.gz --- XMonad/Actions/MouseGestures.hs | 104 ++++++++++++++++++++-------------------- 1 file changed, 51 insertions(+), 53 deletions(-) (limited to 'XMonad/Actions/MouseGestures.hs') diff --git a/XMonad/Actions/MouseGestures.hs b/XMonad/Actions/MouseGestures.hs index 4708314..1fc47e5 100644 --- a/XMonad/Actions/MouseGestures.hs +++ b/XMonad/Actions/MouseGestures.hs @@ -16,8 +16,9 @@ module XMonad.Actions.MouseGestures ( -- * Usage -- $usage Direction(..), + mouseGestureH, mouseGesture, - mouseGestureH + mkCollect ) where import XMonad @@ -25,10 +26,9 @@ import XMonad import Data.IORef import qualified Data.Map as M import Data.Map (Map) +import Data.Maybe import Control.Monad -import System.IO - -- $usage -- -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@: @@ -79,65 +79,63 @@ dir (ax, ay) (bx, by) = trans . (/ pi) $ atan2 (fromIntegral $ ay - by) (fromInt | otherwise = L rg a z x = a <= x && x < z -debugging :: Int -debugging = 0 - -collect :: ([Direction] -> X ()) -> IORef (Pos, [(Direction, Pos, Pos)]) -> Position -> Position -> X () -collect hook st nx ny = do +gauge :: (Direction -> X ()) -> Pos -> IORef (Maybe (Direction, Pos)) -> Position -> Position -> X () +gauge hook op st nx ny = do let np = (nx, ny) - stx@(op, ds) <- io $ readIORef st + stx <- io $ readIORef st let - stx' = - case ds of - [] - | insignificant np op -> stx - | otherwise -> (op, [(dir op np, np, op)]) - (d, zp, ap_) : ds' - | insignificant np zp -> stx - | otherwise -> - let - d' = dir zp np - ds'' - | d == d' = (d, np, ap_) : ds' - | otherwise = (d', np, zp) : ds - in (op, ds'') - when (debugging > 0) - . io . hPutStrLn stderr $ show "Mouse Gesture" ++ unwords (map show (extract stx')) ++ (if debugging > 1 then "; " ++ show op ++ "-" ++ show np else "") - hook (extract stx') - io $ writeIORef st stx' + (~(Just od), pivot) = case stx of + Nothing -> (Nothing, op) + Just (d, zp) -> (Just d, zp) + cont = do + guard $ significant np pivot + return $ do + let d' = dir pivot np + when (isNothing stx || od /= d') $ hook d' + io $ writeIORef st (Just (d', np)) + fromMaybe (return ()) cont where - insignificant a b = delta a b < 10 + significant a b = delta a b >= 10 -extract :: (Pos, [(Direction, Pos, Pos)]) -> [Direction] -extract (_, xs) = reverse . map (\(x, _, _) -> x) $ xs +-- | @'mouseGestureH' moveHook endHook@ is a mouse button +-- event handler. It collects mouse movements, calling @moveHook@ for each +-- update; when the button is released, it calls @endHook@. +mouseGestureH :: (Direction -> X ()) -> X () -> X () +mouseGestureH moveHook endHook = do + dpy <- asks display + root <- asks theRoot + (pos, acc) <- io $ do + (_, _, _, ix, iy, _, _, _) <- queryPointer dpy root + r <- newIORef Nothing + return ((fromIntegral ix, fromIntegral iy), r) + mouseDrag (gauge moveHook pos acc) endHook -- | A utility function on top of 'mouseGestureH'. It uses a 'Data.Map.Map' to -- look up the mouse gesture, then executes the corresponding action (if any). mouseGesture :: Map [Direction] (Window -> X ()) -> Window -> X () -mouseGesture tbl = - mouseGestureH (const . const $ return ()) $ \win gest -> +mouseGesture tbl win = do + (mov, end) <- mkCollect + mouseGestureH (\d -> mov d >> return ()) $ end >>= \gest -> case M.lookup gest tbl of Nothing -> return () Just f -> f win --- | @'mouseGestureH' moveHook endHook gestures window@ is a mouse button --- event handler. It collects mouse movements, calling @moveHook@ for each --- update; when the button is released, it calls @endHook@ with the resulting --- gesture. -mouseGestureH :: (Window -> [Direction] -> X ()) -> (Window -> [Direction] -> X ()) -> Window -> X () -mouseGestureH moveHook endHook win = withDisplay $ \dpy -> do - when (debugging > 1) - . io . hPutStrLn stderr $ "mouseGesture " ++ show (win, dpy) - root <- asks theRoot - let win' = if win == none then root else win - acc <- io $ do - qp@(_, _, _, ix, iy, _, _, _) <- queryPointer dpy win' - when (debugging > 1) - . hPutStrLn stderr $ show "queryPointer" ++ show qp - when (debugging > 1 && win' == none) - . hPutStrLn stderr $ show "mouseGesture" ++ "zomg none" - newIORef ((fromIntegral ix, fromIntegral iy), []) - mouseDrag (collect (moveHook win') acc) $ do - when (debugging > 0) . io . hPutStrLn stderr $ show "" - gest <- io $ liftM extract $ readIORef acc - endHook win' gest +-- | A callback generator for 'mouseGestureH'. 'mkCollect' returns two +-- callback functions for passing to 'mouseGestureH'. The move hook will +-- collect mouse movements (and return the current gesture as a list); the end +-- hook will return a list of the completed gesture, which you can access with +-- 'Control.Monad.>>='. +mkCollect :: (MonadIO m) => m (Direction -> X [Direction], X [Direction]) +mkCollect = liftIO $ do + acc <- newIORef [] + let + mov d = io $ do + ds <- readIORef acc + let ds' = d : ds + writeIORef acc ds' + return $ reverse ds' + end = io $ do + ds <- readIORef acc + writeIORef acc [] + return $ reverse ds + return (mov, end) -- cgit v1.2.3