{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-}
{- |
   Module      : XMonad.Actions.UpKeys
   Description : Bind an action to the release of a key
   Copyright   : (c) Tony Zorman, 2024
   License     : BSD-3
   Maintainer  : Tony Zorman <soliditsallgood@mailbox.org>

A combinator for binding an action to the release of a key. This can be
useful for hold-type buttons, where the press of a key engages some
functionality, and its release… releases it again.
-}
module XMonad.Actions.UpKeys
  ( -- * Usage
    -- $usage
    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

{- $usage
You can use this module with the following in your @xmonad.hs@:

> import XMonad.Actions.UpKeys

Next, define the keys and actions you want to have happen on the release
of a key:

> myUpKeys = ezUpKeys $
>   [ ("M-z", myAction)
>   , ("M-a", myAction2)
>   ]

All that's left is to plug this definition into the 'useUpKeys'
combinator that this module provides:

> main :: IO ()
> main = xmonad
>      . useUpKeys (def{ grabKeys = True, upKeys = myUpKeys })
>      $ myConfig

Note the presence of @'grabKeys' = True@; this is for situations where
you don't have any of these keys bound to do something upon pressing
them; i.e., you use them solely for their release actions. If you want
something to happen in both cases, remove that part (@'grabKeys' =
False@ is the default) and bind the keys to actions as you normally
would.

==== __Examples__

As an extended example, consider the case where you want all of your
docks (e.g., status bar) to "pop up" when you press the super key, and
then vanish again once that keys is released.

Since docks are not generally part of XMonad's window-set—otherwise, we
would have to manage them—we first need a way to access and manipulate
all docks.

> onAllDocks :: (Display -> Window -> IO ()) -> X ()
> onAllDocks act = withDisplay \dpy -> do
>   rootw <- asks theRoot
>   (_, _, wins) <- io $ queryTree dpy rootw
>   traverse_ (io . act dpy) =<< filterM (runQuery checkDock) wins

This is also the place where one could filter for just status bar,
trayer, and so on.

Now we have to decide what kinds of keys we want to watch out for. Since
you most likely use left super as your modifier key, this is a little
bit more complicated than for other keys, as you will most likely see
the key both as a @KeyMask@, as well as a @KeySym@. One could think a
bit and probably come up with an elegant solution for this—or one could
grab all possible key combinations by brute-force!

> dockKeys :: X () -> [((KeyMask, KeySym), X ())]
> dockKeys act = map (actKey . foldr1 (.|.)) . combinations $ keyMasks
>  where
>   actKey :: KeyMask -> ((KeyMask, KeySym), X ())
>   actKey mask = ((mask, xK_Super_L), act)
>
>   keyMasks :: [KeyMask]
>   keyMasks = [ noModMask, shiftMask, lockMask, controlMask, mod1Mask, mod2Mask, mod3Mask, mod4Mask, mod5Mask ]
>
>   -- Return all combinations of a sequence of values.
>   combinations :: [a] -> [[a]]
>   combinations xs = concat [combs i xs | i <- [1 .. length xs]]
>    where
>     combs 0 _      = [[]]
>     combs _ []     = []
>     combs n (x:xs) = map (x:) (combs (n-1) xs) <> combs n xs

Given some action, like lowering or raising the window, we generate all
possible combinations of modifiers that may be pressed with the super
key. This is a good time to say that this is just for demonstrative
purposes, btw—please don't actually do this.

All that's left is to plug everything into the machinery of this module,
and we're done!

> import qualified Data.Map.Strict as Map
>
> main :: IO ()
> main = xmonad
>      . … -- other combinators
>      . useUpKeys (def { upKeys = Map.fromList $ dockKeys (onAllDocks lowerWindow) })
>      $ myConfig `additionalKeys` dockKeys (onAllDocks raiseWindow)
>
> myConfig = …
-}

data UpKeysConfig = UpKeysConfig
  { -- | Whether to grab all keys that are not already grabbed.
    UpKeysConfig -> Bool
grabKeys :: !Bool
    -- | The keys themselves.
  , UpKeysConfig -> Map (KeyMask, KeySym) (X ())
upKeys :: !(Map (KeyMask, KeySym) (X ()))
  }

-- | The default 'UpKeysConfig'; keys are not grabbed, and no upkeys are
-- specified.
instance Default UpKeysConfig where
  def :: UpKeysConfig
  def :: UpKeysConfig
def = UpKeysConfig { grabKeys :: Bool
grabKeys = Bool
False, upKeys :: Map (KeyMask, KeySym) (X ())
upKeys = Map (KeyMask, KeySym) (X ())
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 Map (KeyMask, KeySym) (X ())
-> Map (KeyMask, KeySym) (X ()) -> Map (KeyMask, KeySym) (X ())
forall a. Semigroup a => a -> a -> a
<> Map (KeyMask, KeySym) (X ())
u')

-- | Bind actions to keys upon their release.
useUpKeys :: UpKeysConfig -> (XConfig l -> XConfig l)
useUpKeys :: forall (l :: * -> *). UpKeysConfig -> XConfig l -> XConfig l
useUpKeys UpKeysConfig
upKeysConf = ((XConfig l -> XConfig l)
 -> UpKeysConfig -> XConfig l -> XConfig l)
-> UpKeysConfig
-> (XConfig l -> XConfig l)
-> XConfig l
-> XConfig l
forall a b c. (a -> b -> c) -> b -> a -> c
flip (XConfig l -> XConfig l) -> UpKeysConfig -> XConfig l -> XConfig l
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 = handleEventHook conf <> (\Event
e -> Event -> X ()
handleKeyUp Event
e X () -> All -> X All
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool -> All
All Bool
True)
  , startupHook     = startupHook     conf <> when (grabKeys upKeysConf) grabUpKeys
  }
 where
  grabUpKeys :: X ()
  grabUpKeys :: X ()
grabUpKeys = do
    XConf{ display = dpy, theRoot = rootw } <- X XConf
forall r (m :: * -> *). MonadReader r m => m r
ask
    realKeys <- maybe mempty upKeys <$> XC.ask @X @UpKeysConfig
    let grab :: (KeyMask, KeyCode) -> X ()
        grab (KeyMask
km, KeyCode
kc) = IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
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
    traverse_ grab =<< mkGrabs (Map.keys realKeys)

-- | Parse the given EZConfig-style keys into the internal keymap
-- representation.
--
-- This is just 'mkKeymap' with a better name.
ezUpKeys :: XConfig l -> [(String, X ())] -> Map (KeyMask, KeySym) (X ())
ezUpKeys :: forall (l :: * -> *).
XConfig l -> [(String, X ())] -> Map (KeyMask, KeySym) (X ())
ezUpKeys = XConfig l -> [(String, X ())] -> Map (KeyMask, KeySym) (X ())
forall (l :: * -> *).
XConfig l -> [(String, X ())] -> Map (KeyMask, KeySym) (X ())
mkKeymap

-- | A handler for key-up events.
handleKeyUp :: Event -> X ()
handleKeyUp :: Event -> X ()
handleKeyUp KeyEvent{ EventType
ev_event_type :: EventType
ev_event_type :: Event -> EventType
ev_event_type, KeyMask
ev_state :: KeyMask
ev_state :: Event -> KeyMask
ev_state, KeyCode
ev_keycode :: KeyCode
ev_keycode :: Event -> KeyCode
ev_keycode }
  | EventType
ev_event_type EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
keyRelease = (Display -> X ()) -> X ()
forall a. (Display -> X a) -> X a
withDisplay \Display
dpy -> do
      s   <- IO KeySym -> X KeySym
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO KeySym -> X KeySym) -> IO KeySym -> X KeySym
forall a b. (a -> b) -> a -> b
$ Display -> KeyCode -> CInt -> IO KeySym
keycodeToKeysym Display
dpy KeyCode
ev_keycode CInt
0
      cln <- cleanMask ev_state
      ks  <- maybe mempty upKeys <$> XC.ask @X @UpKeysConfig
      userCodeDef () $ whenJust (ks Map.!? (cln, s)) id
handleKeyUp Event
_ = () -> X ()
forall a. a -> X a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()