-
-
Save sgtrusty/12329fdce59ea54ab2e222277a70a114 to your computer and use it in GitHub Desktop.
Conditional key bindings for xmonad. WIP.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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