Skip to content

Instantly share code, notes, and snippets.

@LSLeary
Last active October 4, 2022 01:27
Show Gist options
  • Save LSLeary/a9ec2edf43cdcc9ccf185e2d79d06e90 to your computer and use it in GitHub Desktop.
Save LSLeary/a9ec2edf43cdcc9ccf185e2d79d06e90 to your computer and use it in GitHub Desktop.
Conditional key bindings for xmonad. WIP.
{-# LANGUAGE StandaloneDeriving, DeriveFunctor, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
--------------------------------------------------------------------------------
-- Module : XMonad.Actions.ConditionalBindings
-- Description : A framework for producing conditional key bindings.
-- Copyright : (c) 2018 L. S. Leary
-- License : BSD3-style (see LICENSE)
--
-- Maintainer : L. S. Leary
-- Stability : unstable
-- Portability : unportable
--
-- Provides functions and conditions with which to generate keybindings
-- conditional upon the current workspace, screen or layout, the floating status
-- or properties of the focused window, or anything else you can express as an
-- @X Bool@ in your config.
--
--------------------------------------------------------------------------------
-- --< Imports & Exports >-- {{{
--module XMonad.Actions.ConditionalBindings (
module ConditionalBindings (
-- * Usage
-- $Usage
-- ** ConditionTree
ConditionTree (..), ActionTree, KeyBindTree,
cWhen, cBranch, cVal,
-- ** KeyBind Generation
conditionalBindings,
discard, passThrough,
runActionTree, runActionTree_,
compileKBTree,
-- ** Conditional Grab
-- $ConditionalGrab
conditionalGrabs,
conditionallyGrabKeys,
-- * Conditions
-- $Conditions
workspaceIs, screenIs, layoutIs,
-- ** Focal Conditions
-- $FocalConditions
theFocus, isFloat, exists, has, (/=?)
) where
import Data.Semigroup (Any (..))
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import XMonad
import qualified XMonad.StackSet as W
import XMonad.Util.Paste (sendKey)
--import XMonad.Hooks.RefocusLast (isFloat)
import RefocusLast (isFloat)
import XMonad.Util.PureX
--import XMonad.Util.Grab
import Grab
-- }}}
-- --< Usage >-- {{{
-- $Usage
--
-- The core of this module is the @ConditionTree m a@ type of which @ActionTree@
-- and @KeyBindTree@ are simple specialisations. @ActionTree@ can be used to
-- directly build up each individual binding, but the @KeyBindTree@ interface is
-- recommended and, in effect, "compiles down" to the same structure.
--
-- The way the @KeyBindTree@ is translated down is clever enough that despite
-- the potentially hairy appearance of the full tree, executing a given binding
-- only requires testing conditions directly relevant to it. To give some
-- examples with the tree below:
--
-- > Branch
-- > [ When cond1 (Val kbs1)
-- > , When cond2 $ Branch
-- > [ When cond3 (Val kbs2)
-- > , When cond4 (Val kbs3)
-- > , Val kbs4
-- > ]
-- > , Val kbs5
-- > ]
--
-- * If a key is only bound in @kbs5@ then no conditions are tested when it
-- runs; its @ActionTree@ looks like:
--
-- > Val x
--
-- * If a key is only bound in @kbs3@ then @cond2@ is tested when it runs.
-- If it is satisfied then we proceed to test @cond4@ before running the
-- bound action. Its @ActionTree@ looks like:
--
-- > When cond2 $
-- > When cond4 (Val x)
--
-- * If a key is bound in all of @kbs1@ through @kbs5@, then the resulting
-- @ActionTree@ has the same shape as the @KeyBindTree@. If @cond1@ holds
-- then the associated action will run, otherwise @cond2@ will be tested,
-- etc.
--
-- In the following example config, more convenient forms of the tree
-- constructors are used which make certain assumptions; see their documentation
-- for details.
--
-- > import XMonad
-- > import XMonad.Actions.ConditionalBindings
-- >
-- > main :: IO ()
-- > main = xmonad $ def
-- > { keys = conditionalBindings passThrough myKeyBindTree }
-- >
-- > myKeyBindTree :: XConfig Layout -> KeyBindTree
-- > myKeyBindTree = cBranch
-- > [ cVal unconKeys
-- > , When toggledOn . cBranch
-- > [ cWhen (theFocus isFloat) floatKeys
-- > , cWhen (layoutIs "Full") lFullKeys
-- > , cWhen (theFocus . has $ className /=? "mpv") audioKeys
-- > , cWhen (screenIs (S 0) <&&> theFocus exists) scrn0Keys
-- > , cWhen (workspaceIs "1" <||> workspaceIs "2") ws1o2Keys
-- > , cWhen (not <$> workspaceIs "3") noWs3Keys
-- > , cVal basicKeys
-- > , Val . keys def
-- > ]
-- > ] where
-- > unconKeys cnf = ...
-- > floatKeys cnf = ...
-- > lFullKeys cnf = ...
-- > scrn0Keys cnf = ...
-- > ws1o2Keys cnf = ...
-- > noWs3Keys cnf = ...
-- > audioKeys cnf = ...
-- > basicKeys cnf = ...
-- }}}
-- --< ConditionTree >-- {{{
-- | Syntax Tree for @m@-conditional @a@ values.
data ConditionTree m a
-- | A unary branch decorated with an @m@-condition.
= When (m Bool) (ConditionTree m a)
-- | An undecorated n-ary branch.
| Branch [ConditionTree m a]
-- | A leaf holding an @a@.
| Val a
deriving Functor
deriving instance (Show a, Show (m Bool)) => Show (ConditionTree m a)
instance Semigroup (ConditionTree m a) where
Branch [] <> ct = ct
ct <> Branch [] = ct
ct1 <> ct2 = Branch (toList ct1 ++ toList ct2)
where toList = \case Branch cts -> cts
ct -> [ct]
instance Monoid (ConditionTree m a) where
mappend = (<>)
mempty = Branch []
-- | Type Synonym for a @ConditionTree X@ over an action.
type ActionTree = ConditionTree X (X ())
-- | Type Synonym for a @ConditionTree X@ over key bindings.
type KeyBindTree = ConditionTree X (M.Map (KeyMask, KeySym) (X ()))
-- | Convenience constructor. Treats its condition argument normally but only
-- accepts the @Val@ case for its second argument, and in doing so inherits
-- the assumptions made by @cVal@.
cWhen
:: Ord k => m Bool -> (x -> [(k, a)]) -> (x -> ConditionTree m (M.Map k a))
cWhen cond l = When cond . cVal l
-- | Convenience constructor. Assumes its children are functions to
-- @ConditionTree@s as e.g. produced by @cWhen@, @cVal@ or itself, and
-- produces a function in turn.
cBranch :: [x -> ConditionTree m a] -> (x -> ConditionTree m a)
cBranch l = Branch . sequence l
-- | Convenience constructor. Assumes its argument is a function to a list of
-- key-value pairs rather than a @Map@, hence produces a function that will
-- construct a @Map@.
cVal :: Ord k => (x -> [(k, a)]) -> (x -> ConditionTree m (M.Map k a))
cVal l = Val . M.fromList . l
-- }}}
-- --< KeyBind Generation >-- {{{
-- | Produce from an @ActionTree@ an @X Bool@ checking the requisite conditions
-- and performing an action if conditions are satisfied, returning its
-- success.
runActionTree :: ActionTree -> X Bool
runActionTree = \case
Val action -> True <$ action
When cond at -> cond >>= \case
True -> runActionTree at
False -> pure False
Branch [] -> pure False
Branch (at:l) -> runActionTree at >>= \case
True -> pure True
False -> runActionTree (Branch l)
-- | Attempt to run an @ActionTree@, performing a default action in case of
-- failure.
runActionTree_ :: X () -> ActionTree -> X ()
runActionTree_ dflt at = whenM' (not <$> runActionTree at) dflt
-- | Invert a @ConditionTree@ over @Map@s to a @Map@ over @ConditionTree@s,
-- hence compile a @KeyBindTree@ down to bindings in @ActionTree@ form.
compileKBTree
:: Ord k => ConditionTree m (M.Map k a) -> M.Map k (ConditionTree m a)
compileKBTree = \case
Val kbs -> M.map Val kbs
When cond kbsp -> M.map (When cond) (compileKBTree kbsp)
Branch ats -> M.unionsWith (<>) (compileKBTree <$> ats)
-- | Given an uncaught-case handler (supplied with the relevant keypress)
-- and conditional bindings, generate regular ones via @compileKBTree@ and
-- @runActionTree_@.
conditionalBindings
:: ((KeyMask, KeySym) -> X ())
-> (XConfig Layout -> KeyBindTree)
-> (XConfig Layout -> M.Map (KeyMask, KeySym) (X ()))
conditionalBindings handleNoMeet cKeys
= M.mapWithKey (runActionTree_ . handleNoMeet) . compileKBTree . cKeys
-- | Uncaught-case handler: capture the keypress and discard it.
discard :: (KeyMask, KeySym) -> X ()
discard = \_ -> return ()
-- | Uncaught-case handler: pass the keypress through to the focused window.
passThrough :: (KeyMask, KeySym) -> X ()
passThrough = uncurry sendKey
-- }}}
-- --< Conditonal Grab >-- {{{
-- $ConditonalGrab
--
-- TODO
--
-- | TODO
conditionalGrabs :: (XConfig Layout -> KeyBindTree) -> XConfig l -> XConfig l
conditionalGrabs kbt conf = conf
{ startupHook = startupHook conf >> cgrab
, logHook = logHook conf >> cgrab
, keys = conditionalBindings discard kbt
, handleEventHook = handleEventHook conf <> customRegrabEvHook cgrab
} where cgrab = conditionallyGrabKeys kbt
-- | Grab the keys for which conditions are met.
conditionallyGrabKeys :: (XConfig Layout -> KeyBindTree) -> X ()
conditionallyGrabKeys kbt = do
grab . S.toList =<< getGrabs . kbt =<< asks config
trace "xmonad conditionallyGrabKeys: let's see how often this runs"
where
getGrabs = \case
Val b -> pure (M.keysSet b)
When c b -> whenM' c (getGrabs b)
Branch bs -> mconcat <$> traverse getGrabs bs
-- }}}
-- --< Conditions >-- {{{
-- $Conditions
--
-- The condition primitives in this section can be readily extended, combined or
-- modified. In particular, basic logical operations are available:
--
-- * @not <$> cond@ holds iff @cond@ does not.
-- * @cond1 <&&> cond2@ holds iff both @cond1@ and @cond2@ hold when evaluated
-- in that order.
-- * @cond1 <||> cond2@ holds iff at least one of @cond1@ or @cond2@ holds when
-- evaluated in that order.
--
-- | Holds iff the current workspace has the supplied tag.
workspaceIs :: XLike m => WorkspaceId -> m Bool
workspaceIs wksp = (wksp ==) <$> curTag
-- | Holds iff the current screen has the supplied ID.
screenIs :: XLike m => ScreenId -> m Bool
screenIs sid = (sid ==) <$> curScreenId
-- | Holds iff the layout of the current workspace has the supplied description.
layoutIs :: XLike m => String -> m Bool
layoutIs desc = (desc ==) . description . W.layout <$> curWorkspace
-- }}}
-- --< Focal Conditions >-- {{{
-- $FocalConditions
--
-- Conditions on the focused window can be used via @theFocus@. Further, such
-- conditions can be created by giving to @has@ a @ManageHook@ style condition:
-- a @Query Bool@, usually used as the left argument to '-->'.
-- | Holds iff there is a focused window and it satisfies the supplied
-- condition.
theFocus :: XLike m => (Window -> m Bool) -> m Bool
theFocus f = do
mw <- peek
getAny <$> (whenJust' mw $ \w -> Any <$> f w)
-- | Will always hold, given a focus.
exists :: Window -> X Bool
exists = \_ -> pure True
-- | Produce a condition on the focus, given a @Query Bool@.
has :: Query Bool -> (Window -> X Bool)
has = runQuery
-- | Like '=?' but tests for inequality instead; @qs /=? s@ is a more convenient
-- form of @not <$> (qs =? s)@.
(/=?) :: Query String -> String -> Query Bool
qs /=? s = (s /=) <$> qs
-- }}}
@geekosaur
Copy link

Part of me thinks this is ridiculously complicated, part of me thinks this is similar to a ManageHook. I guess I'd have to see it in practice (and see how much of it actually got used, and how confused users are about using it).

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment