Conditional key bindings for xmonad. WIP.

ConditionalBindings.hs

{-# 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

-- }}}

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).