Skip to content

Instantly share code, notes, and snippets.

@sgtrusty
Forked from LSLeary/ConditionalBindings.hs
Created October 4, 2022 01:27
Show Gist options
  • Save sgtrusty/12329fdce59ea54ab2e222277a70a114 to your computer and use it in GitHub Desktop.
Save sgtrusty/12329fdce59ea54ab2e222277a70a114 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
-- }}}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment