{-# 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.Foldable                  ( traverse_ )
-- base
import           Data.Semigroup                 ( All(..) )

-- }}}

-- --< 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 -> Window
theRoot = Window
rootw } <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display
-> KeyCode
-> KeyMask
-> Window
-> Bool
-> MappingRequest
-> MappingRequest
-> IO ()
grabKey Display
dpy KeyCode
kc KeyMask
mdfr Window
rootw Bool
True MappingRequest
grabModeAsync MappingRequest
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 -> Window
theRoot = Window
rootw } <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> KeyCode -> KeyMask -> Window -> IO ()
ungrabKey Display
dpy KeyCode
kc KeyMask
mdfr Window
rootw)

-- | A convenience function to grab and ungrab keys
grabUngrab
  :: [(KeyMask, KeySym)] -- ^  Keys to grab
  -> [(KeyMask, KeySym)] -- ^ Keys to ungrab
  -> X ()
grabUngrab :: [(KeyMask, Window)] -> [(KeyMask, Window)] -> X ()
grabUngrab [(KeyMask, Window)]
gr [(KeyMask, Window)]
ugr = do
  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) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(KeyMask, Window)] -> X [(KeyMask, KeyCode)]
mkGrabs [(KeyMask, Window)]
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)   forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(KeyMask, Window)] -> X [(KeyMask, KeyCode)]
mkGrabs [(KeyMask, Window)]
gr

-- | A convenience function to grab keys. This also ungrabs all
-- previously grabbed keys.
grab :: [(KeyMask, KeySym)] -> X ()
grab :: [(KeyMask, Window)] -> X ()
grab [(KeyMask, Window)]
ks = do
  XConf { display :: XConf -> Display
display = Display
dpy, theRoot :: XConf -> Window
theRoot = Window
rootw } <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> KeyCode -> KeyMask -> Window -> IO ()
ungrabKey Display
dpy KeyCode
anyKey KeyMask
anyModifier Window
rootw)
  [(KeyMask, Window)] -> [(KeyMask, Window)] -> X ()
grabUngrab [(KeyMask, Window)]
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 -> MappingRequest
ev_request Event
e forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [MappingRequest
mappingKeyboard, MappingRequest
mappingModifier])
      forall a b. (a -> b) -> a -> b
$  X ()
cacheNumlockMask
      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)

-- }}}