{-# 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 :: KeyMask -> KeyCode -> X ()
grabKP KeyMask
mdfr KeyCode
kc = do
  XConf { display :: XConf -> Display
display = Display
dpy, theRoot :: XConf -> KeySym
theRoot = KeySym
rootw } <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display
-> KeyCode -> KeyMask -> KeySym -> Bool -> CInt -> CInt -> IO ()
grabKey Display
dpy KeyCode
kc KeyMask
mdfr KeySym
rootw Bool
True CInt
grabModeAsync CInt
grabModeAsync)

-- | A more convenient version of 'ungrabKey'.
ungrabKP :: KeyMask -> KeyCode -> X ()
ungrabKP :: KeyMask -> KeyCode -> X ()
ungrabKP KeyMask
mdfr KeyCode
kc = do
  XConf { display :: XConf -> Display
display = Display
dpy, theRoot :: XConf -> KeySym
theRoot = KeySym
rootw } <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> KeyCode -> KeyMask -> KeySym -> IO ()
ungrabKey Display
dpy KeyCode
kc KeyMask
mdfr KeySym
rootw)

-- | A convenience function to grab and ungrab keys
grabUngrab
  :: [(KeyMask, KeySym)] -- ^  Keys to grab
  -> [(KeyMask, KeySym)] -- ^ Keys to ungrab
  -> X ()
grabUngrab :: [(KeyMask, KeySym)] -> [(KeyMask, KeySym)] -> X ()
grabUngrab [(KeyMask, KeySym)]
gr [(KeyMask, KeySym)]
ugr = do
  [(KeyMask, KeySym)] -> [(KeyMask, KeyCode)]
f <- X ([(KeyMask, KeySym)] -> [(KeyMask, KeyCode)])
mkGrabs
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry KeyMask -> KeyCode -> X ()
ungrabKP) ([(KeyMask, KeySym)] -> [(KeyMask, KeyCode)]
f [(KeyMask, KeySym)]
ugr)
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry KeyMask -> KeyCode -> X ()
grabKP)   ([(KeyMask, KeySym)] -> [(KeyMask, KeyCode)]
f [(KeyMask, KeySym)]
gr)

-- | A convenience function to grab keys. This also ungrabs all
-- previously grabbed keys.
grab :: [(KeyMask, KeySym)] -> X ()
grab :: [(KeyMask, KeySym)] -> X ()
grab [(KeyMask, KeySym)]
ks = do
  XConf { display :: XConf -> Display
display = Display
dpy, theRoot :: XConf -> KeySym
theRoot = KeySym
rootw } <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> KeyCode -> KeyMask -> KeySym -> IO ()
ungrabKey Display
dpy KeyCode
anyKey KeyMask
anyModifier KeySym
rootw)
  [(KeyMask, KeySym)] -> [(KeyMask, KeySym)] -> X ()
grabUngrab [(KeyMask, KeySym)]
ks []

-- | An event hook that runs a custom action to regrab the necessary keys.
customRegrabEvHook :: X () -> Event -> X All
customRegrabEvHook :: X () -> Event -> X All
customRegrabEvHook X ()
regr = \case
  e :: Event
e@MappingNotifyEvent{} -> do
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Event -> IO ()
refreshKeyboardMapping Event
e)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Event -> CInt
ev_request Event
e forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CInt
mappingKeyboard, CInt
mappingModifier])
      forall a b. (a -> b) -> a -> b
$  X ()
setNumlockMask
      forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> X ()
regr
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> All
All Bool
False)
  Event
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> All
All Bool
True)

-- }}}

-- --< Private Utils >-- {{{

-- | Private action shamelessly copied and restyled from XMonad.Main source.
setNumlockMask :: X ()
setNumlockMask :: X ()
setNumlockMask = forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
  [(KeyMask, [KeyCode])]
ms <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> IO [(KeyMask, [KeyCode])]
getModifierMapping Display
dpy)
  [KeyMask]
xs <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
    [ do
        KeySym
ks <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> KeyCode -> CInt -> IO KeySym
keycodeToKeysym Display
dpy KeyCode
kc CInt
0)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if KeySym
ks forall a. Eq a => a -> a -> Bool
== KeySym
xK_Num_Lock
          then forall a. Bits a => a -> Int -> a
setBit KeyMask
0 (forall a b. (Integral a, Num b) => a -> b
fromIntegral KeyMask
m)
          else KeyMask
0 :: KeyMask
    | (KeyMask
m, [KeyCode]
kcs) <- [(KeyMask, [KeyCode])]
ms
    , KeyCode
kc       <- [KeyCode]
kcs
    , KeyCode
kc forall a. Eq a => a -> a -> Bool
/= KeyCode
0
    ]
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XState
s -> XState
s { numberlockMask :: KeyMask
numberlockMask = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. Bits a => a -> a -> a
(.|.) KeyMask
0 [KeyMask]
xs }

-- | Private function shamelessly copied and refactored from XMonad.Main source.
mkGrabs :: X ([(KeyMask, KeySym)] -> [(KeyMask, KeyCode)])
mkGrabs :: X ([(KeyMask, KeySym)] -> [(KeyMask, KeyCode)])
mkGrabs = forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
  let (CInt
minCode, CInt
maxCode) = Display -> (CInt, CInt)
displayKeycodes Display
dpy
      allCodes :: [KeyCode]
allCodes           = [forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
minCode .. forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
maxCode]
  [KeySym]
syms <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [KeyCode]
allCodes forall a b. (a -> b) -> a -> b
$ \KeyCode
code -> Display -> KeyCode -> CInt -> IO KeySym
keycodeToKeysym Display
dpy KeyCode
code CInt
0
  let keysymMap :: Map KeySym [KeyCode]
keysymMap = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith forall a. [a] -> [a] -> [a]
(++) (forall a b. [a] -> [b] -> [(a, b)]
zip [KeySym]
syms forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [KeyCode]
allCodes)
      keysymToKeycodes :: KeySym -> [KeyCode]
keysymToKeycodes KeySym
sym = forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] KeySym
sym Map KeySym [KeyCode]
keysymMap
  [KeyMask]
extraMods <- X [KeyMask]
extraModifiers
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \[(KeyMask, KeySym)]
ks -> do
    (KeyMask
mask, KeySym
sym) <- [(KeyMask, KeySym)]
ks
    KeyCode
keycode     <- KeySym -> [KeyCode]
keysymToKeycodes KeySym
sym
    KeyMask
extraMod    <- [KeyMask]
extraMods
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyMask
mask forall a. Bits a => a -> a -> a
.|. KeyMask
extraMod, KeyCode
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.