{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-}
module XMonad.Actions.UpKeys
(
useUpKeys,
UpKeysConfig (..),
ezUpKeys,
)
where
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import XMonad
import XMonad.Prelude
import XMonad.Util.EZConfig (mkKeymap)
import qualified XMonad.Util.ExtensibleConf as XC
data UpKeysConfig = UpKeysConfig
{
UpKeysConfig -> Bool
grabKeys :: !Bool
, UpKeysConfig -> Map (KeyMask, KeySym) (X ())
upKeys :: !(Map (KeyMask, KeySym) (X ()))
}
instance Default UpKeysConfig where
def :: UpKeysConfig
def :: UpKeysConfig
def = UpKeysConfig { grabKeys :: Bool
grabKeys = Bool
False, upKeys :: Map (KeyMask, KeySym) (X ())
upKeys = forall a. Monoid a => a
mempty }
instance Semigroup UpKeysConfig where
(<>) :: UpKeysConfig -> UpKeysConfig -> UpKeysConfig
UpKeysConfig Bool
g Map (KeyMask, KeySym) (X ())
u <> :: UpKeysConfig -> UpKeysConfig -> UpKeysConfig
<> UpKeysConfig Bool
g' Map (KeyMask, KeySym) (X ())
u' = Bool -> Map (KeyMask, KeySym) (X ()) -> UpKeysConfig
UpKeysConfig (Bool
g Bool -> Bool -> Bool
&& Bool
g') (Map (KeyMask, KeySym) (X ())
u forall a. Semigroup a => a -> a -> a
<> Map (KeyMask, KeySym) (X ())
u')
useUpKeys :: UpKeysConfig -> (XConfig l -> XConfig l)
useUpKeys :: forall (l :: * -> *). UpKeysConfig -> XConfig l -> XConfig l
useUpKeys UpKeysConfig
upKeysConf = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a (l :: * -> *).
(Semigroup a, Typeable a) =>
(XConfig l -> XConfig l) -> a -> XConfig l -> XConfig l
XC.once UpKeysConfig
upKeysConf \XConfig l
conf -> XConfig l
conf
{ handleEventHook :: Event -> X All
handleEventHook = forall (l :: * -> *). XConfig l -> Event -> X All
handleEventHook XConfig l
conf forall a. Semigroup a => a -> a -> a
<> (\Event
e -> Event -> X ()
handleKeyUp Event
e forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool -> All
All Bool
True)
, startupHook :: X ()
startupHook = forall (l :: * -> *). XConfig l -> X ()
startupHook XConfig l
conf forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UpKeysConfig -> Bool
grabKeys UpKeysConfig
upKeysConf) X ()
grabUpKeys
}
where
grabUpKeys :: X ()
grabUpKeys :: X ()
grabUpKeys = do
XConf{ display :: XConf -> Display
display = Display
dpy, theRoot :: XConf -> KeySym
theRoot = KeySym
rootw } <- forall r (m :: * -> *). MonadReader r m => m r
ask
Map (KeyMask, KeySym) (X ())
realKeys <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty UpKeysConfig -> Map (KeyMask, KeySym) (X ())
upKeys forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(MonadReader XConf m, Typeable a) =>
m (Maybe a)
XC.ask @X @UpKeysConfig
let grab :: (KeyMask, KeyCode) -> X ()
grab :: (KeyMask, KeyCode) -> X ()
grab (KeyMask
km, KeyCode
kc) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display
-> KeyCode -> KeyMask -> KeySym -> Bool -> CInt -> CInt -> IO ()
grabKey Display
dpy KeyCode
kc KeyMask
km KeySym
rootw Bool
True CInt
grabModeAsync CInt
grabModeAsync
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (KeyMask, KeyCode) -> X ()
grab forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(KeyMask, KeySym)] -> X [(KeyMask, KeyCode)]
mkGrabs (forall k a. Map k a -> [k]
Map.keys Map (KeyMask, KeySym) (X ())
realKeys)
ezUpKeys :: XConfig l -> [(String, X ())] -> Map (KeyMask, KeySym) (X ())
ezUpKeys :: forall (l :: * -> *).
XConfig l -> [(String, X ())] -> Map (KeyMask, KeySym) (X ())
ezUpKeys = forall (l :: * -> *).
XConfig l -> [(String, X ())] -> Map (KeyMask, KeySym) (X ())
mkKeymap
handleKeyUp :: Event -> X ()
handleKeyUp :: Event -> X ()
handleKeyUp KeyEvent{ EventType
ev_event_type :: Event -> EventType
ev_event_type :: EventType
ev_event_type, KeyMask
ev_state :: Event -> KeyMask
ev_state :: KeyMask
ev_state, KeyCode
ev_keycode :: Event -> KeyCode
ev_keycode :: KeyCode
ev_keycode }
| EventType
ev_event_type forall a. Eq a => a -> a -> Bool
== EventType
keyRelease = forall a. (Display -> X a) -> X a
withDisplay \Display
dpy -> do
KeySym
s <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> KeyCode -> CInt -> IO KeySym
keycodeToKeysym Display
dpy KeyCode
ev_keycode CInt
0
KeyMask
cln <- KeyMask -> X KeyMask
cleanMask KeyMask
ev_state
Map (KeyMask, KeySym) (X ())
ks <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty UpKeysConfig -> Map (KeyMask, KeySym) (X ())
upKeys forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(MonadReader XConf m, Typeable a) =>
m (Maybe a)
XC.ask @X @UpKeysConfig
forall a. a -> X a -> X a
userCodeDef () forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (Map (KeyMask, KeySym) (X ())
ks forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? (KeyMask
cln, KeySym
s)) forall a. a -> a
id
handleKeyUp Event
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()