{-# 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 hiding (mkGrabs)
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.