Factor shared logic out of X.A.Cycle* modules

These modules were duplicating a substantial amount of low-level code. `X.A.CycleWorkspaceByScreen` had already separated most of the implementation details from the logic with `repeatableAction`; all that was left was to generalise it a little further, put it in a suitable place and express the other modules through it.
2025-07-26 09:41:52 -07:00 · 2022-10-21 21:01:27 +13:00
parent e85f0151b2
commit dd7855da3d
6 changed files with 136 additions and 62 deletions
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -11,6 +11,11 @@
    - Deprecated the module in favour of the (new) exclusive scratchpad
      functionality of `XMonad.Util.NamedScratchpad`.

+  * `XMonad.Actions.CycleWorkspaceByScreen`
+
+    - The type of `repeatableAction` has changed, and it's deprecated in
+      favour of `X.A.Repeatable.repeatable`.
+
  * `XMonad.Hooks.DynamicProperty`

    - Deprecated the module in favour of the more aptly named
@@ -72,6 +77,11 @@

 ### New Modules

+  * `XMonad.Actions.Repeatable`
+
+    - Actions you'd like to repeat. Factors out the shared logic of
+      `X.A.CycleRecentWS`, `X.A.CycleWorkspaceByScreen` and `X.A.CycleWindows`.
+
  * `XMonad.Hooks.OnPropertyChange`:

    - A new module replicating the functionality of
--- a/XMonad/Actions/CycleRecentWS.hs
+++ b/XMonad/Actions/CycleRecentWS.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE MultiWayIf #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonad.Actions.CycleRecentWS
@@ -35,11 +36,15 @@ module XMonad.Actions.CycleRecentWS (
 #endif
 ) where

+import XMonad.Actions.Repeatable (repeatableSt)
+
 import XMonad hiding (workspaces)
-import XMonad.StackSet hiding (filter)
+import XMonad.StackSet hiding (filter, modify)

 import Control.Arrow ((&&&))
 import Data.Function (on)
+import Data.Functor (void)
+import Control.Monad.State (lift, when)

 -- $usage
 -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@ file:
@@ -111,25 +116,15 @@ cycleWindowSets :: (WindowSet -> [WorkspaceId]) -- ^ A function used to create a
                -> X ()
 cycleWindowSets genOptions mods keyNext keyPrev = do
  (options, unView') <- gets $ (genOptions &&& unView) . windowset
-  XConf {theRoot = root, display = d} <- ask
-  let event = allocaXEvent $ \p -> do
-                maskEvent d (keyPressMask .|. keyReleaseMask) p
-                KeyEvent {ev_event_type = t, ev_keycode = c} <- getEvent p
-                s <- keycodeToKeysym d c 0
-                return (t, s)
-  let setOption n = do windows $ view (options `cycref` n) . unView'
-                       (t, s) <- io event
-                       case () of
-                         () | t == keyPress   && s == keyNext  -> setOption (n+1)
-                            | t == keyPress   && s == keyPrev  -> setOption (n-1)
-                            | t == keyRelease && s `elem` mods -> return ()
-                            | otherwise                        -> setOption n
-  io $ grabKeyboard d root False grabModeAsync grabModeAsync currentTime
-  setOption 0
-  io $ ungrabKeyboard d currentTime
- where
-  cycref :: [a] -> Int -> a
-  cycref l i = l !! (i `mod` length l)
+  let
+    preview = do
+      i <- get
+      lift $ windows (view (options !! (i `mod` n)) . unView')
+      where n = length options
+  void . repeatableSt (-1) mods keyNext $ \t s -> when (t == keyPress) $ if
+    | s == keyNext -> modify succ >> preview
+    | s == keyPrev -> modify pred >> preview
+    | otherwise    -> pure ()

 -- | Given an old and a new 'WindowSet', which is __exactly__ one
 -- 'view' away from the old one, restore the workspace order of the
--- a/XMonad/Actions/CycleWindows.hs
+++ b/XMonad/Actions/CycleWindows.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ViewPatterns, MultiWayIf #-}

 --------------------------------------------------------------------------------
 -- |
@@ -59,8 +59,10 @@ import XMonad.Prelude
 import qualified XMonad.StackSet as W
 import qualified Data.List.NonEmpty as NE
 import XMonad.Actions.RotSlaves
+import XMonad.Actions.Repeatable (repeatableSt)

 import Control.Arrow (second)
+import Control.Monad.Trans (lift)

 -- $usage
 -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@ file:
@@ -139,27 +141,19 @@ cycleStacks' :: (W.Stack Window -> [W.Stack Window]) -- ^ A function to a finite
                                    -> KeySym    -- ^ Key used to select a \"previous\" stack.
                                    -> X ()
 cycleStacks' filteredPerms mods keyNext keyPrev = do
-    XConf {theRoot = root, display = d} <- ask
-    stacks <- gets $ maybe [] filteredPerms . W.stack . W.workspace . W.current . windowset
-
-    let evt = allocaXEvent $
-                  \p -> do maskEvent d (keyPressMask .|. keyReleaseMask) p
-                           KeyEvent {ev_event_type = t, ev_keycode = c} <- getEvent p
-                           s <- keycodeToKeysym d c 0
-                           return (t, s)
-        choose n (t, s)
-              | t == keyPress   && s == keyNext  = io evt >>= choose (n+1)
-              | t == keyPress   && s == keyPrev  = io evt >>= choose (n-1)
-              | t == keyPress   && s `elem` [xK_0..xK_9] = io evt >>= choose (numKeyToN s)
-              | t == keyRelease && s `elem` mods = return ()
-              | otherwise                        = doStack n >> io evt >>= choose n
-        doStack n = windows . W.modify' . const $ stacks `cycref` n
-
-    io $ grabKeyboard d root False grabModeAsync grabModeAsync currentTime
-    io evt >>= choose 1
-    io $ ungrabKeyboard d currentTime
-  where cycref l i = l !! (i `mod` length l) -- modify' ensures l is never [], but must also be finite
-        numKeyToN = subtract 48 . read . show
+  stacks <- gets $ maybe [] filteredPerms
+                 . W.stack . W.workspace . W.current . windowset
+  let
+    preview = do
+      i <- get
+      lift . windows . W.modify' . const $ stacks !! (i `mod` n)
+      where n = length stacks
+  void $ repeatableSt 0 mods keyNext $ \t s -> if
+    | t == keyPress && s == keyNext          -> modify succ
+    | t == keyPress && s == keyPrev          -> modify pred
+    | t == keyPress && s `elem` [xK_0..xK_9] -> put (numKeyToN s)
+    | otherwise                              -> preview
+  where numKeyToN = subtract 48 . read . show

 -- | Given a stack element and a stack, shift or insert the element (window)
 --   at the currently focused position.
--- a/XMonad/Actions/CycleWorkspaceByScreen.hs
+++ b/XMonad/Actions/CycleWorkspaceByScreen.hs
@@ -25,11 +25,10 @@ module XMonad.Actions.CycleWorkspaceByScreen (

 import           Data.IORef

-import           Graphics.X11.Xlib.Extras
-
 import           XMonad
 import           XMonad.Prelude
 import           XMonad.Hooks.WorkspaceHistory
+import           XMonad.Actions.Repeatable (repeatable)
 import qualified XMonad.StackSet as W

 -- $usage
@@ -53,22 +52,9 @@ import qualified XMonad.StackSet as W
 --
 -- > , ((mod4Mask, xK_slash), cycleWorkspaceOnCurrentScreen [xK_Super_L] xK_slash xK_p)

-repeatableAction :: [KeySym] -> (EventType -> KeySym -> X ()) -> X ()
-repeatableAction mods pressHandler = do
-  XConf {theRoot = root, display = d} <- ask
-  let getNextEvent = io $ allocaXEvent $ \p ->
-                 do
-                   maskEvent d (keyPressMask .|. keyReleaseMask) p
-                   KeyEvent {ev_event_type = t, ev_keycode = c} <- getEvent p
-                   s <- io $ keycodeToKeysym d c 0
-                   return (t, s)
-      handleEvent (t, s)
-        | t == keyRelease && s `elem` mods = return ()
-        | otherwise = pressHandler t s >> getNextEvent >>= handleEvent
-
-  io $ grabKeyboard d root False grabModeAsync grabModeAsync currentTime
-  getNextEvent >>= handleEvent
-  io $ ungrabKeyboard d currentTime
+{-# DEPRECATED repeatableAction "Use XMonad.Actions.Repeatable.repeatable" #-}
+repeatableAction :: [KeySym] -> KeySym -> (EventType -> KeySym -> X ()) -> X ()
+repeatableAction = repeatable

 handleKeyEvent :: EventType
               -> KeySym
@@ -109,8 +95,7 @@ cycleWorkspaceOnScreen screenId mods nextKey prevKey = workspaceHistoryTransacti
        return $ cycleWorkspaces !! current
      focusIncrement i = io (getAndIncrementWS i) >>= (windows . W.greedyView)

-  focusIncrement 1 -- Do the first workspace cycle
-  repeatableAction mods $
+  repeatable mods nextKey $
    runFirst
      [ handleKeyEvent keyPress nextKey $ focusIncrement 1
      , handleKeyEvent keyPress prevKey $ focusIncrement (-1)
--- a/XMonad/Actions/Repeatable.hs
+++ b/XMonad/Actions/Repeatable.hs
@@ -0,0 +1,88 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonad.Actions.Repeatable
+-- Description :  Actions you'd like to repeat.
+-- Copyright   :  (c) 2022 L. S. Leary
+-- License     :  BSD3-style (see LICENSE)
+--
+-- Maintainer  :  @LSLeary (on github)
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- This module factors out the shared logic of "XMonad.Actions.CycleRecentWS",
+-- "XMonad.Actions.CycleWorkspaceByScreen" and "XMonad.Actions.CycleWindows".
+--
+-- See the source of these modules for usage examples.
+--
+-----------------------------------------------------------------------------
+
+module XMonad.Actions.Repeatable
+  ( repeatable
+  , repeatableSt
+  , repeatableM
+  ) where
+
+-- mtl
+import Control.Monad.State (StateT(..))
+
+-- X11
+import Graphics.X11.Xlib.Extras
+
+-- xmonad
+import XMonad
+
+
+-- | An action that temporarily usurps and responds to key press/release events,
+--   concluding when one of the modifier keys is released.
+repeatable
+  :: [KeySym]                      -- ^ The list of 'KeySym's under the
+                                   --   modifiers used to invoke the action.
+  -> KeySym                        -- ^ The keypress that invokes the action.
+  -> (EventType -> KeySym -> X ()) -- ^ The keypress handler.
+  -> X ()
+repeatable = repeatableM id
+
+-- | A more general variant of 'repeatable' with a stateful handler,
+--   accumulating a monoidal return value throughout the events.
+repeatableSt
+  :: Monoid a
+  => s                                     -- ^ Initial state.
+  -> [KeySym]                              -- ^ The list of 'KeySym's under the
+                                           --   modifiers used to invoke the
+                                           --   action.
+  -> KeySym                                -- ^ The keypress that invokes the
+                                           --   action.
+  -> (EventType -> KeySym -> StateT s X a) -- ^ The keypress handler.
+  -> X (a, s)
+repeatableSt iSt = repeatableM $ \m -> runStateT m iSt
+
+-- | A more general variant of 'repeatable' with an arbitrary monadic handler,
+--   accumulating a monoidal return value throughout the events.
+repeatableM
+  :: (MonadIO m, Monoid a)
+  => (m a -> X b)                 -- ^ How to run the monad in 'X'.
+  -> [KeySym]                     -- ^ The list of 'KeySym's under the
+                                  --   modifiers used to invoke the action.
+  -> KeySym                       -- ^ The keypress that invokes the action.
+  -> (EventType -> KeySym -> m a) -- ^ The keypress handler.
+  -> X b
+repeatableM run mods key pressHandler = do
+  XConf{ theRoot = root, display = d } <- ask
+  run (repeatableRaw d root mods key pressHandler)
+
+repeatableRaw
+  :: (MonadIO m, Monoid a)
+  => Display -> Window
+  -> [KeySym] -> KeySym -> (EventType -> KeySym -> m a) -> m a
+repeatableRaw d root mods key pressHandler = do
+  io (grabKeyboard d root False grabModeAsync grabModeAsync currentTime)
+  handleEvent (keyPress, key) <* io (ungrabKeyboard d currentTime)
+  where
+    getNextEvent = io $ allocaXEvent $ \p -> do
+      maskEvent d (keyPressMask .|. keyReleaseMask) p
+      KeyEvent{ ev_event_type = t, ev_keycode = c } <- getEvent p
+      s <- keycodeToKeysym d c 0
+      return (t, s)
+    handleEvent (t, s)
+      | t == keyRelease && s `elem` mods = pure mempty
+      | otherwise = (<>) <$> pressHandler t s <*> (getNextEvent >>= handleEvent)
--- a/xmonad-contrib.cabal
+++ b/xmonad-contrib.cabal
@@ -132,6 +132,7 @@ library
                        XMonad.Actions.Promote
                        XMonad.Actions.RandomBackground
                        XMonad.Actions.RepeatAction
+                        XMonad.Actions.Repeatable
                        XMonad.Actions.RotSlaves
                        XMonad.Actions.RotateSome
                        XMonad.Actions.Search
@@ -415,6 +416,7 @@ test-suite tests
                  XMonad.Actions.FocusNth
                  XMonad.Actions.GridSelect
                  XMonad.Actions.PhysicalScreens
+                  XMonad.Actions.Repeatable
                  XMonad.Actions.RotateSome
                  XMonad.Actions.Submap
                  XMonad.Actions.SwapWorkspaces