diff options
Diffstat (limited to 'src/Rahm/Desktop/Submap.hs')
| -rw-r--r-- | src/Rahm/Desktop/Submap.hs | 112 |
1 files changed, 58 insertions, 54 deletions
diff --git a/src/Rahm/Desktop/Submap.hs b/src/Rahm/Desktop/Submap.hs index 5a05f9e..aabc35b 100644 --- a/src/Rahm/Desktop/Submap.hs +++ b/src/Rahm/Desktop/Submap.hs @@ -1,5 +1,5 @@ -module Rahm.Desktop.Submap ( - mapNextString, +module Rahm.Desktop.Submap + ( mapNextString, mapNextStringWithKeysym, submapButtonsWithKey, nextButton, @@ -7,28 +7,27 @@ module Rahm.Desktop.Submap ( nextMotionOrButton, submap, submapDefault, - submapDefaultWithKey) where + submapDefaultWithKey, + ) +where -import Rahm.Desktop.Common -import Control.Monad.Trans.Maybe -import Control.Monad.Trans +import Control.Concurrent (threadDelay) import Control.Monad (void) -import XMonad hiding (keys) import Control.Monad.Fix (fix) -import qualified Data.Map as Map +import Control.Monad.Trans +import Control.Monad.Trans.Maybe import Data.Map (Map) -import Control.Concurrent (threadDelay) -import Data.Word (Word64) +import qualified Data.Map as Map import Data.Time.Clock.POSIX - +import Data.Word (Word64) +import Rahm.Desktop.Common +import XMonad hiding (keys) currentTimeMillis :: IO Int -currentTimeMillis = round . (*1000) <$> getPOSIXTime - +currentTimeMillis = round . (* 1000) <$> getPOSIXTime getMaskEventWithTimeout :: Int -> Display -> Word64 -> (XEventPtr -> IO a) -> IO (Maybe a) - getMaskEventWithTimeout timeout d mask fn = do curTime <- currentTimeMillis allocaXEvent $ \ptr -> do @@ -36,8 +35,6 @@ getMaskEventWithTimeout timeout d mask fn = do if val then Just <$> fn ptr else return Nothing - - where getMaskEventWithTimeout' ptr timeout = do curTime <- currentTimeMillis @@ -61,24 +58,24 @@ getMaskEventWithTimeout timeout d mask fn = do mapNextStringWithKeysym :: (KeyMask -> KeySym -> String -> MaybeT X a) -> MaybeT X a mapNextStringWithKeysym fn = do - XConf { theRoot = root, display = d } <- ask + XConf {theRoot = root, display = d} <- ask io $ grabKeyboard d root False grabModeAsync grabModeAsync currentTime - ret <- io $ fix $ \nextkey -> do - ret <- - getMaskEventWithTimeout 5000 d keyPressMask $ \p -> do - KeyEvent { ev_keycode = code, ev_state = m } <- getEvent p - keysym <- keycodeToKeysym d code 0 - (_, str) <- lookupString (asKeyEvent p) - return (m, str, keysym) - - case ret of - Just (m, str, keysym) -> - if isModifierKey keysym + ret <- io $ + fix $ \nextkey -> do + ret <- + getMaskEventWithTimeout 5000 d keyPressMask $ \p -> do + KeyEvent {ev_keycode = code, ev_state = m} <- getEvent p + keysym <- keycodeToKeysym d code 0 + (_, str) <- lookupString (asKeyEvent p) + return (m, str, keysym) + + case ret of + Just (m, str, keysym) -> + if isModifierKey keysym then nextkey else return ret - - Nothing -> return Nothing + Nothing -> return Nothing io $ ungrabKeyboard d currentTime @@ -92,7 +89,7 @@ mapNextString fn = mapNextStringWithKeysym (\m _ s -> fn m s) submapDefaultWithKey :: ((KeyMask, KeySym) -> X ()) -> Map (KeyMask, KeySym) (X ()) -> X () submapDefaultWithKey def m = runMaybeT_ $ mapNextStringWithKeysym $ \mask sym _ -> lift $ do - Map.findWithDefault (def (mask, sym)) (mask, sym) m + Map.findWithDefault (def (mask, sym)) (mask, sym) m submapDefault :: X () -> Map (KeyMask, KeySym) (X ()) -> X () submapDefault def = submapDefaultWithKey (const def) @@ -104,12 +101,13 @@ submap = submapDefault (return ()) -- next button is pressed. nextButton :: X (Maybe (ButtonMask, Button)) nextButton = do - XConf { theRoot = root, display = d } <- ask + XConf {theRoot = root, display = d} <- ask io $ grabPointer d root False buttonPressMask grabModeAsync grabModeAsync 0 0 currentTime - ret <- io $ getMaskEventWithTimeout 1000 d buttonPressMask $ \xEv -> do - ButtonEvent { ev_button = button, ev_state = m } <- getEvent xEv - return (m, button) + ret <- io $ + getMaskEventWithTimeout 1000 d buttonPressMask $ \xEv -> do + ButtonEvent {ev_button = button, ev_state = m} <- getEvent xEv + return (m, button) io $ ungrabPointer d currentTime @@ -118,13 +116,14 @@ nextButton = do {- Grabs the mouse and reports the next mouse motion. -} nextMotion :: X (Int, Int) nextMotion = do - XConf { theRoot = root, display = d } <- ask + XConf {theRoot = root, display = d} <- ask io $ grabPointer d root False pointerMotionMask grabModeAsync grabModeAsync 0 0 currentTime - ret <- io $ allocaXEvent $ \xEv -> do - maskEvent d pointerMotionMask xEv - MotionEvent { ev_x = x, ev_y = y } <- getEvent xEv - return (fromIntegral x, fromIntegral y) + ret <- io $ + allocaXEvent $ \xEv -> do + maskEvent d pointerMotionMask xEv + MotionEvent {ev_x = x, ev_y = y} <- getEvent xEv + return (fromIntegral x, fromIntegral y) io $ ungrabPointer d currentTime @@ -133,26 +132,31 @@ nextMotion = do {- Grabs the mouse and reports the next mouse motion or button press. -} nextMotionOrButton :: X (Either (Int, Int) (ButtonMask, Button)) nextMotionOrButton = do - XConf { theRoot = root, display = d } <- ask + 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) + 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 () + ((ButtonMask, Button) -> Window -> X ()) -> Map (ButtonMask, Button) (Window -> X ()) -> Window -> X () submapButtonsWithKey defaultAction actions window = do - maybe (return ()) (\arg -> - case Map.lookup arg actions of - Nothing -> defaultAction arg window - Just fn -> fn window) =<< nextButton + maybe + (return ()) + ( \arg -> + case Map.lookup arg actions of + Nothing -> defaultAction arg window + Just fn -> fn window + ) + =<< nextButton |