New Module: XMonad.Util.Grab

Based on the draft by L. S.
Leary.  (https://gist.github.com/LSLeary/6741b0572d62db3f0cea8e6618141b2f).

CHANGES.md

@@ -74,6 +74,10 @@
     A module for adding a keybinding to repeat the last action, similar
     to Vim's `.` or Emacs's `dot-mode`.
 
+ * `XMonad.Util.Grab`
+
+    Utilities for making grabbing and ungrabbing keys more convenient.
+
 ### Bug Fixes and Minor Changes
 
   * `XMonad.Prompt.OrgMode`

XMonad/Util/Grab.hs

@@ -0,0 +1,136 @@
+{-# LANGUAGE LambdaCase #-}
+
+--------------------------------------------------------------------------------
+-- |
+-- Module      :  XMonad.Util.Grab
+-- Description :  Utilities for grabbing/ungrabbing keys.
+-- Copyright   :  (c) 2018  L. S. Leary
+-- License     :  BSD3-style (see LICENSE)
+--
+-- Maintainer  :  L. S. Leary
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- This module should not be directly used by users. Its purpose is to
+-- facilitate grabbing and ungrabbing keys.
+--------------------------------------------------------------------------------
+
+-- --< Imports & Exports >-- {{{
+
+module XMonad.Util.Grab
+  (
+ -- * Usage
+ -- $Usage
+    grabKP
+  , ungrabKP
+  , grabUngrab
+  , grab
+  , customRegrabEvHook
+  ) where
+
+-- core
+import           XMonad
+
+import           Control.Monad                  ( when )
+import           Data.Bits                      ( setBit )
+import           Data.Foldable                  ( traverse_ )
+-- base
+import qualified Data.Map.Strict               as M
+import           Data.Semigroup                 ( All(..) )
+import           Data.Traversable               ( for )
+
+-- }}}
+
+-- --< Usage >-- {{{
+
+-- $Usage
+--
+-- This module should not be directly used by users. Its purpose is to
+-- facilitate grabbing and ungrabbing keys.
+
+-- }}}
+
+-- --< Public Utils >-- {{{
+
+-- | A more convenient version of 'grabKey'.
+grabKP :: KeyMask -> KeyCode -> X ()
+grabKP mdfr kc = do
+  XConf { display = dpy, theRoot = rootw } <- ask
+  io (grabKey dpy kc mdfr rootw True grabModeAsync grabModeAsync)
+
+-- | A more convenient version of 'ungrabKey'.
+ungrabKP :: KeyMask -> KeyCode -> X ()
+ungrabKP mdfr kc = do
+  XConf { display = dpy, theRoot = rootw } <- ask
+  io (ungrabKey dpy kc mdfr rootw)
+
+-- | A convenience function to grab and ungrab keys
+grabUngrab
+  :: [(KeyMask, KeySym)] -- ^  Keys to grab
+  -> [(KeyMask, KeySym)] -- ^ Keys to ungrab
+  -> X ()
+grabUngrab gr ugr = do
+  f <- mkGrabs
+  traverse_ (uncurry ungrabKP) (f ugr)
+  traverse_ (uncurry grabKP)   (f gr)
+
+-- | A convenience function to grab keys. This also ungrabs all
+-- previously grabbed keys.
+grab :: [(KeyMask, KeySym)] -> X ()
+grab ks = do
+  XConf { display = dpy, theRoot = rootw } <- ask
+  io (ungrabKey dpy anyKey anyModifier rootw)
+  grabUngrab ks []
+
+-- | An event hook that runs a custom action to regrab the necessary keys.
+customRegrabEvHook :: X () -> Event -> X All
+customRegrabEvHook regr = \case
+  e@MappingNotifyEvent{} -> do
+    io (refreshKeyboardMapping e)
+    when (ev_request e `elem` [mappingKeyboard, mappingModifier])
+      $  setNumlockMask
+      >> regr
+    pure (All False)
+  _ -> pure (All True)
+
+-- }}}
+
+-- --< Private Utils >-- {{{
+
+-- | Private action shamelessly copied and restyled from XMonad.Main source.
+setNumlockMask :: X ()
+setNumlockMask = withDisplay $ \dpy -> do
+  ms <- io (getModifierMapping dpy)
+  xs <- sequence
+    [ do
+        ks <- io (keycodeToKeysym dpy kc 0)
+        pure $ if ks == xK_Num_Lock
+          then setBit 0 (fromIntegral m)
+          else 0 :: KeyMask
+    | (m, kcs) <- ms
+    , kc       <- kcs
+    , kc /= 0
+    ]
+  modify $ \s -> s { numberlockMask = foldr (.|.) 0 xs }
+
+-- | Private function shamelessly copied and refactored from XMonad.Main source.
+mkGrabs :: X ([(KeyMask, KeySym)] -> [(KeyMask, KeyCode)])
+mkGrabs = withDisplay $ \dpy -> do
+  let (minCode, maxCode) = displayKeycodes dpy
+      allCodes           = [fromIntegral minCode .. fromIntegral maxCode]
+  syms <- io . for allCodes $ \code -> keycodeToKeysym dpy code 0
+  let keysymMap = M.fromListWith (++) (zip syms $ pure <$> allCodes)
+      keysymToKeycodes sym = M.findWithDefault [] sym keysymMap
+  extraMods <- extraModifiers
+  pure $ \ks -> do
+    (mask, sym) <- ks
+    keycode     <- keysymToKeycodes sym
+    extraMod    <- extraMods
+    pure (mask .|. extraMod, keycode)
+
+-- }}}
+
+
+-- NOTE: there is some duplication between this module and core. The
+-- latter probably will never change, but this needs to be kept in sync
+-- with any potential bugs that might arise.

xmonad-contrib.cabal

@@ -353,6 +353,7 @@ library
                         XMonad.Util.ExtensibleConf
                         XMonad.Util.ExtensibleState
                         XMonad.Util.Font
+                        XMonad.Util.Grab
                         XMonad.Util.Hacks
                         XMonad.Util.Image
                         XMonad.Util.Invisible