diff options
Diffstat (limited to 'src/Rahm/Desktop/Submap.hs')
| -rw-r--r-- | src/Rahm/Desktop/Submap.hs | 78 |
1 files changed, 78 insertions, 0 deletions
diff --git a/src/Rahm/Desktop/Submap.hs b/src/Rahm/Desktop/Submap.hs index b705a24..9c20381 100644 --- a/src/Rahm/Desktop/Submap.hs +++ b/src/Rahm/Desktop/Submap.hs @@ -8,19 +8,28 @@ module Rahm.Desktop.Submap submap, submapDefault, submapDefaultWithKey, + ButtonOrKeyEvent (..), + nextButtonOrKeyEvent, + getStringForKey, escape, ) where import Control.Concurrent (threadDelay) +import Control.Exception (SomeException (SomeException), catch) +import Control.Monad (when) import Control.Monad.Fix (fix) import Control.Monad.Trans (MonadTrans (lift)) import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import Data.Aeson (Result (Error)) +import Data.Bits ((.&.)) +import Data.Char (toUpper) import Data.Map (Map) import qualified Data.Map as Map (findWithDefault, lookup) import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Word (Word64) import Rahm.Desktop.Common (pointerWindow, runMaybeT_) +import Rahm.Desktop.Logger (logs) import XMonad ( Button, ButtonMask, @@ -37,6 +46,7 @@ import XMonad XEventPtr, allocaXEvent, asKeyEvent, + asks, buttonPressMask, checkMaskEvent, cleanMask, @@ -49,14 +59,19 @@ import XMonad isModifierKey, keyPressMask, keycodeToKeysym, + keysymToKeycode, + keysymToString, lookupString, maskEvent, pointerMotionMask, + setKeyEvent, + shiftMask, ungrabKeyboard, ungrabPointer, (.|.), ) import qualified XMonad.Util.ExtensibleState as XS +import XMonad.Util.Loggers (logSp) newtype Escape = Escape Bool @@ -98,6 +113,51 @@ getMaskEventWithTimeout timeout d mask fn = do then return True else threadDelay 1000 >> getMaskEventWithTimeout' ptr timeout +data ButtonOrKeyEvent + = ButtonPress + { event_mask :: KeyMask, + event_button :: Button + } + | KeyPress + { event_mask :: KeyMask, + event_keysym :: KeySym, + event_string :: String + } + +nextButtonOrKeyEvent :: MaybeT X ButtonOrKeyEvent +nextButtonOrKeyEvent = do + b <- lift getEscape + when b (MaybeT (return Nothing)) + + XConf {theRoot = root, display = d} <- ask + io $ do + grabKeyboard d root False grabModeAsync grabModeAsync currentTime + grabPointer d root False buttonPressMask grabModeAsync grabModeAsync 0 0 currentTime + + ret <- MaybeT $ + io $ + fix $ \tryAgain -> do + ret <- + getMaskEventWithTimeout 5000 d (keyPressMask .|. buttonPressMask) $ \p -> do + ev <- getEvent p + case ev of + ButtonEvent {ev_button = b, ev_state = m} -> + return $ ButtonPress m b + KeyEvent {ev_keycode = code, ev_state = m} -> do + keysym <- keycodeToKeysym d code 0 + (_, str) <- lookupString (asKeyEvent p) + return $ KeyPress m keysym str + case ret of + Just (KeyPress m sym str) | isModifierKey sym -> tryAgain + x -> return x + + io $ do + ungrabKeyboard d currentTime + ungrabPointer d currentTime + + m' <- lift $ cleanMask (event_mask ret) + return ret {event_mask = m'} + {- - Like submap fram XMonad.Actions.Submap, but sends the string from - XLookupString to the function along side the keysym. @@ -134,6 +194,24 @@ mapNextStringWithKeysym fn = do m <- lift $ cleanMask m' fn m keysym str +-- getStringForKey :: (KeyMask, KeySym) -> X String +-- getStringForKey (m, sym) = do +-- d <- asks display +-- io $ +-- allocaXEvent +-- ( \xev -> do +-- kc <- keysymToKeycode d sym +-- setKeyEvent xev 0 0 0 m kc False +-- (_, str) <- lookupString (asKeyEvent xev) +-- return str +-- ) +-- `catch` ( \e -> do +-- putStrLn $ "Error in getStringForKey: " ++ show (e :: SomeException) +-- return "?" +-- ) +getStringForKey :: (KeyMask, KeySym) -> String +getStringForKey (m, sym) = (if (m .&. shiftMask) /= 0 then map toUpper else id) (keysymToString sym) + {- Like submap, but on the character typed rather than the kysym. -} mapNextString :: (KeyMask -> String -> MaybeT X a) -> MaybeT X a mapNextString fn = mapNextStringWithKeysym (\m _ s -> fn m s) |