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)
+                                      mask <- liftX $ cleanKeyMask <*> pure (ev_state ev)
-                                      keyhandler (fromMaybe xK_VoidSymbol ks, s, mask)
+                                      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' <- cleanKeyMask <*> pure m
-    m' <- cleanMask $ m .&. ((1 `shiftL` 12) - 1)
     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
+          -> GC -> XMonadFont -> [String] -> XPConfig -> (KeyMask -> KeyMask)
-          -> XPState
+          -> Dimension -> XPState
-initState d rw w s opMode gc fonts h c nm width =
+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
+                    if ev_event_type ev == keyPress
-                              then lookupString $ asKeyEvent e
+                        then do (_, s) <- lookupString $ asKeyEvent e
-                              else return (Nothing, "")
+                                ks <- keycodeToKeysym d (ev_keycode ev) 0
-                    return (fromMaybe xK_VoidSymbol ks,s,ev)
+                                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