Merge pull request #686 from liskin/keypress-fixes

X.{A.{{Grid,Tree}Select,Submap},Prompt}: KeyPress handling fixes

CHANGES.md

@@ -132,6 +132,13 @@
  - Added `visualSubmap` to visualise the available keys and their
  actions when inside a submap.
 
+ * `XMonad.Prompt`, `XMonad.Actions.TreeSelect`, `XMonad.Actions.GridSelect`
+
+ - Key bindings now behave similarly to xmonad core:
+ State of mouse buttons and XKB layout groups is ignored.
+ Translation of key codes to symbols ignores modifiers, so `Shift-Tab` is
+ now just `(shiftMap, xK_Tab)` instead of `(shiftMap, xK_ISO_Left_Tab)`.
+
 ## 0.17.0 (October 27, 2021)
 
 ### Breaking Changes

XMonad/Actions/GridSelect.hs

@@ -407,10 +407,11 @@ makeXEventhandler keyhandler = fix $ \me -> join $ liftX $ withDisplay $ \d -> l
  ev <- getEvent e
  if ev_event_type ev == keyPress
  then do
- (ks,s) <- lookupString $ asKeyEvent e
+ (_, s) <- lookupString $ asKeyEvent e
+ ks <- keycodeToKeysym d (ev_keycode ev) 0
  return $ do
- mask <- liftX $ cleanMask (ev_state ev)
- keyhandler (fromMaybe xK_VoidSymbol ks, s, mask)
+ mask <- liftX $ cleanKeyMask <*> pure (ev_state ev)
+ keyhandler (ks, s, mask)
  else
  return $ stdHandle ev me
 

XMonad/Actions/Submap.hs

@@ -27,7 +27,7 @@ module XMonad.Actions.Submap (
 import Data.Bits
 import qualified Data.Map as M
 import XMonad hiding (keys)
-import XMonad.Prelude (fix, fromMaybe, keyToString)
+import XMonad.Prelude (fix, fromMaybe, keyToString, cleanKeyMask)
 import XMonad.Util.XUtils
 
 {- $usage
@@ -138,8 +138,7 @@ waitForKeyPress = do
  then nextkey
  else return (m, keysym)
  _ -> return (0, 0)
- -- Remove num lock mask and Xkb group state bits
- m' <- cleanMask $ m .&. ((1 `shiftL` 12) - 1)
+ m' <- cleanKeyMask <*> pure m
  io $ do ungrabPointer dpy currentTime
  ungrabKeyboard dpy currentTime
  sync dpy False

XMonad/Actions/TreeSelect.hs

@@ -533,11 +533,11 @@ navigate = gets tss_display >>= \d -> join . liftIO . allocaXEvent $ \e -> do
  ev <- getEvent e
 
  if | ev_event_type ev == keyPress -> do
- (ks, _) <- lookupString $ asKeyEvent e
+ ks <- keycodeToKeysym d (ev_keycode ev) 0
  return $ do
- mask <- liftX $ cleanMask (ev_state ev)
+ mask <- liftX $ cleanKeyMask <*> pure (ev_state ev)
  f <- asks ts_navigate
- fromMaybe navigate $ M.lookup (mask, fromMaybe xK_VoidSymbol ks) f
+ fromMaybe navigate $ M.lookup (mask, ks) f
  | ev_event_type ev == buttonPress -> do
  -- See XMonad.Prompt Note [Allow ButtonEvents]
  allowEvents d replayPointer currentTime

XMonad/Prelude.hs

@@ -24,6 +24,7 @@ module XMonad.Prelude (
  safeGetWindowAttributes,
  keyToString,
  keymaskToString,
+ cleanKeyMask,
 ) where
 
 import Foreign (alloca, peek)
@@ -116,3 +117,18 @@ keymaskToString numLockMask msk =
 -- pair, into a string.
 keyToString :: (KeyMask, KeySym) -> [Char]
 keyToString = uncurry (++) . bimap (keymaskToString 0) keysymToString
+
+-- | Strip numlock, capslock, mouse buttons and XKB group from a 'KeyMask',
+-- leaving only modifier keys like Shift, Control, Super, Hyper in the mask
+-- (hence the \"Key\" in \"cleanKeyMask\").
+--
+-- Core's 'cleanMask' only strips the first two because key events from
+-- passive grabs (key bindings) are stripped of mouse buttons and XKB group by
+-- the X server already for compatibility reasons. For more info, see:
+-- <https://www.x.org/releases/X11R7.7/doc/kbproto/xkbproto.html#Delivering_a_Key_or_Button_Event_to_a_Client>
+cleanKeyMask :: X (KeyMask -> KeyMask)
+cleanKeyMask = cleanKeyMask' <$> gets numberlockMask
+
+cleanKeyMask' :: KeyMask -> KeyMask -> KeyMask
+cleanKeyMask' numLockMask mask =
+ mask .&. complement (numLockMask .|. lockMask) .&. (button1Mask - 1)

XMonad/Prompt.hs

@@ -99,7 +99,6 @@ module XMonad.Prompt
 
 import XMonad hiding (cleanMask, config)
 import XMonad.Prelude hiding (toList)
-import qualified XMonad as X (numberlockMask)
 import qualified XMonad.StackSet as W
 import XMonad.Util.Font
 import XMonad.Util.Types
@@ -150,7 +149,7 @@ data XPState =
  , offset :: !Int
  , config :: XPConfig
  , successful :: Bool
- , numlockMask :: KeyMask
+ , cleanMask  :: KeyMask -> KeyMask
  , done :: Bool
  , modeDone :: Bool
  , color :: XPColor
@@ -357,9 +356,9 @@ amberXPConfig = def { bgColor = "black"
  }
 
 initState :: Display -> Window -> Window -> Rectangle -> XPOperationMode
- -> GC -> XMonadFont -> [String] -> XPConfig -> KeyMask -> Dimension
- -> XPState
-initState d rw w s opMode gc fonts h c nm width =
+ -> GC -> XMonadFont -> [String] -> XPConfig -> (KeyMask -> KeyMask)
+ -> Dimension -> XPState
+initState d rw w s opMode gc fonts h c cm width =
  XPS { dpy = d
  , rootw = rw
  , win = w
@@ -382,7 +381,7 @@ initState d rw w s opMode gc fonts h c nm width =
  , successful = False
  , done = False
  , modeDone = False
- , numlockMask = nm
+ , cleanMask  = cm
  , prompter = defaultPrompter c
  , color = defaultColor c
  , eventBuffer = []
@@ -555,7 +554,7 @@ mkXPromptImplementation :: String -> XPConfig -> XPOperationMode -> X XPState
 mkXPromptImplementation historyKey conf om = do
  XConf { display = d, theRoot = rw } <- ask
  s <- gets $ screenRect . W.screenDetail . W.current . windowset
- numlock <- gets X.numberlockMask
+ cleanMask <- cleanKeyMask
  cachedir <- asks (cacheDir . directories)
  hist <- io $ readHistory cachedir
  fs <- initXMF (font conf)
@@ -572,7 +571,7 @@ mkXPromptImplementation historyKey conf om = do
  selectInput d w $ exposureMask .|. keyPressMask
  setGraphicsExposures d gc False
  let hs = fromMaybe [] $ M.lookup historyKey hist
- st = initState d rw w s om gc fs hs conf numlock width
+ st = initState d rw w s om gc fs hs conf cleanMask width
  runXP st))
  releaseXMF fs
  when (successful st') $ do
@@ -595,15 +594,6 @@ mkXPromptImplementation historyKey conf om = do
  CenteredAt{ xpWidth } -> floor $ fi (rect_width scr) * xpWidth
  _ -> rect_width scr
 
--- | Removes numlock and capslock from a keymask.
--- Duplicate of cleanMask from core, but in the
--- XP monad instead of X.
-cleanMask :: KeyMask -> XP KeyMask
-cleanMask msk = do
- numlock <- gets numlockMask
- let highMasks = 1 `shiftL` 12 - 1
- return (complement (numlock .|. lockMask) .&. msk .&. highMasks)
-
 -- | Inverse of 'Codec.Binary.UTF8.String.utf8Encode', that is, a convenience
 -- function that checks to see if the input string is UTF8 encoded before
 -- decoding.
@@ -647,10 +637,11 @@ eventLoop handle stopAction = do
  -- Also capture @buttonPressMask@, see Note [Allow ButtonEvents]
  maskEvent d (exposureMask .|. keyPressMask .|. buttonPressMask) e
  ev <- getEvent e
- (ks,s) <- if ev_event_type ev == keyPress
- then lookupString $ asKeyEvent e
- else return (Nothing, "")
- return (fromMaybe xK_VoidSymbol ks,s,ev)
+ if ev_event_type ev == keyPress
+ then do (_, s) <- lookupString $ asKeyEvent e
+ ks <- keycodeToKeysym d (ev_keycode ev) 0
+ return (ks, s, ev)
+ else return (noSymbol, "", ev)
  l -> do
  modify $ \s -> s { eventBuffer = tail l }
  return $ head l
@@ -699,7 +690,7 @@ merely discarded, but passed to the respective application window.
 handleMain :: KeyStroke -> Event -> XP ()
 handleMain stroke@(keysym,_) KeyEvent{ev_event_type = t, ev_state = m} = do
  (compKey,modeKey) <- gets $ (completionKey &&& changeModeKey) . config
- keymask <- cleanMask m
+ keymask <- gets cleanMask <*> pure m
  -- haven't subscribed to keyRelease, so just in case
  when (t == keyPress) $
  if (keymask,keysym) == compKey
@@ -831,7 +822,7 @@ handleSubmap :: XP ()
  -> Event
  -> XP ()
 handleSubmap defaultAction keymap stroke KeyEvent{ev_event_type = t, ev_state = m} = do
- keymask <- cleanMask m
+ keymask <- gets cleanMask <*> pure m
  when (t == keyPress) $ handleInputSubmap defaultAction keymap keymask stroke
 handleSubmap _ _ stroke event = handleOther stroke event
 
@@ -888,7 +879,7 @@ handleBuffer :: (String -> String -> (Bool,Bool))
  -> Event
  -> XP ()
 handleBuffer f stroke event@KeyEvent{ev_event_type = t, ev_state = m} = do
- keymask <- cleanMask m
+ keymask <- gets cleanMask <*> pure m
  when (t == keyPress) $ handleInputBuffer f keymask stroke event
 handleBuffer _ stroke event = handleOther stroke event