{-# 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 } <- X XConf
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> X ()
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 } <- X XConf
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> X ()
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
  ((KeyMask, KeyCode) -> X ()) -> [(KeyMask, KeyCode)] -> X ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((KeyMask -> KeyCode -> X ()) -> (KeyMask, KeyCode) -> X ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry KeyMask -> KeyCode -> X ()
ungrabKP) ([(KeyMask, KeySym)] -> [(KeyMask, KeyCode)]
f [(KeyMask, KeySym)]
ugr)
  ((KeyMask, KeyCode) -> X ()) -> [(KeyMask, KeyCode)] -> X ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((KeyMask -> KeyCode -> X ()) -> (KeyMask, KeyCode) -> X ()
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 } <- X XConf
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> X ()
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
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Event -> IO ()
refreshKeyboardMapping Event
e)
    Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Event -> CInt
ev_request Event
e CInt -> [CInt] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CInt
mappingKeyboard, CInt
mappingModifier])
      (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$  X ()
setNumlockMask
      X () -> X () -> X ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> X ()
regr
    All -> X All
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> All
All Bool
False)
  Event
_ -> All -> X All
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 = (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ()) -> X ()) -> (Display -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
  [(KeyMask, [KeyCode])]
ms <- IO [(KeyMask, [KeyCode])] -> X [(KeyMask, [KeyCode])]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> IO [(KeyMask, [KeyCode])]
getModifierMapping Display
dpy)
  [KeyMask]
xs <- [X KeyMask] -> X [KeyMask]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
    [ do
        KeySym
ks <- IO KeySym -> X KeySym
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> KeyCode -> CInt -> IO KeySym
keycodeToKeysym Display
dpy KeyCode
kc CInt
0)
        KeyMask -> X KeyMask
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyMask -> X KeyMask) -> KeyMask -> X KeyMask
forall a b. (a -> b) -> a -> b
$ if KeySym
ks KeySym -> KeySym -> Bool
forall a. Eq a => a -> a -> Bool
== KeySym
xK_Num_Lock
          then KeyMask -> Int -> KeyMask
forall a. Bits a => a -> Int -> a
setBit KeyMask
0 (KeyMask -> Int
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 KeyCode -> KeyCode -> Bool
forall a. Eq a => a -> a -> Bool
/= KeyCode
0
    ]
  (XState -> XState) -> X ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XState -> XState) -> X ()) -> (XState -> XState) -> X ()
forall a b. (a -> b) -> a -> b
$ \XState
s -> XState
s { numberlockMask :: KeyMask
numberlockMask = (KeyMask -> KeyMask -> KeyMask) -> KeyMask -> [KeyMask] -> KeyMask
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr KeyMask -> KeyMask -> KeyMask
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 = (Display -> X ([(KeyMask, KeySym)] -> [(KeyMask, KeyCode)]))
-> X ([(KeyMask, KeySym)] -> [(KeyMask, KeyCode)])
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ([(KeyMask, KeySym)] -> [(KeyMask, KeyCode)]))
 -> X ([(KeyMask, KeySym)] -> [(KeyMask, KeyCode)]))
-> (Display -> X ([(KeyMask, KeySym)] -> [(KeyMask, KeyCode)]))
-> X ([(KeyMask, KeySym)] -> [(KeyMask, KeyCode)])
forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
  let (CInt
minCode, CInt
maxCode) = Display -> (CInt, CInt)
displayKeycodes Display
dpy
      allCodes :: [KeyCode]
allCodes           = [CInt -> KeyCode
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
minCode .. CInt -> KeyCode
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
maxCode]
  [KeySym]
syms <- IO [KeySym] -> X [KeySym]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [KeySym] -> X [KeySym])
-> ((KeyCode -> IO KeySym) -> IO [KeySym])
-> (KeyCode -> IO KeySym)
-> X [KeySym]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [KeyCode] -> (KeyCode -> IO KeySym) -> IO [KeySym]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [KeyCode]
allCodes ((KeyCode -> IO KeySym) -> X [KeySym])
-> (KeyCode -> IO KeySym) -> X [KeySym]
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 = ([KeyCode] -> [KeyCode] -> [KeyCode])
-> [(KeySym, [KeyCode])] -> Map KeySym [KeyCode]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith [KeyCode] -> [KeyCode] -> [KeyCode]
forall a. [a] -> [a] -> [a]
(++) ([KeySym] -> [[KeyCode]] -> [(KeySym, [KeyCode])]
forall a b. [a] -> [b] -> [(a, b)]
zip [KeySym]
syms ([[KeyCode]] -> [(KeySym, [KeyCode])])
-> [[KeyCode]] -> [(KeySym, [KeyCode])]
forall a b. (a -> b) -> a -> b
$ KeyCode -> [KeyCode]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyCode -> [KeyCode]) -> [KeyCode] -> [[KeyCode]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [KeyCode]
allCodes)
      keysymToKeycodes :: KeySym -> [KeyCode]
keysymToKeycodes KeySym
sym = [KeyCode] -> KeySym -> Map KeySym [KeyCode] -> [KeyCode]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] KeySym
sym Map KeySym [KeyCode]
keysymMap
  [KeyMask]
extraMods <- X [KeyMask]
extraModifiers
  ([(KeyMask, KeySym)] -> [(KeyMask, KeyCode)])
-> X ([(KeyMask, KeySym)] -> [(KeyMask, KeyCode)])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([(KeyMask, KeySym)] -> [(KeyMask, KeyCode)])
 -> X ([(KeyMask, KeySym)] -> [(KeyMask, KeyCode)]))
-> ([(KeyMask, KeySym)] -> [(KeyMask, KeyCode)])
-> X ([(KeyMask, KeySym)] -> [(KeyMask, KeyCode)])
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
    (KeyMask, KeyCode) -> [(KeyMask, KeyCode)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyMask
mask KeyMask -> KeyMask -> KeyMask
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.