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.

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

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
-  let event = allocaXEvent $ \p -> do
+    preview = do
-                maskEvent d (keyPressMask .|. keyReleaseMask) p
+      i <- get
-                KeyEvent {ev_event_type = t, ev_keycode = c} <- getEvent p
+      lift $ windows (view (options !! (i `mod` n)) . unView')
-                s <- keycodeToKeysym d c 0
+      where n = length options
-                return (t, s)
+  void . repeatableSt (-1) mods keyNext $ \t s -> when (t == keyPress) $ if
-  let setOption n = do windows $ view (options `cycref` n) . unView'
+    | s == keyNext -> modify succ >> preview
-                       (t, s) <- io event
+    | s == keyPrev -> modify pred >> preview
-                       case () of
+    | otherwise    -> pure ()
-                         () | 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)
 
 -- | Given an old and a new 'WindowSet', which is __exactly__ one
 -- 'view' away from the old one, restore the workspace order of the

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
-    stacks <- gets $ maybe [] filteredPerms . W.stack . W.workspace . W.current . windowset
+                 . W.stack . W.workspace . W.current . windowset
-
+  let
-    let evt = allocaXEvent $
+    preview = do
-                  \p -> do maskEvent d (keyPressMask .|. keyReleaseMask) p
+      i <- get
-                           KeyEvent {ev_event_type = t, ev_keycode = c} <- getEvent p
+      lift . windows . W.modify' . const $ stacks !! (i `mod` n)
-                           s <- keycodeToKeysym d c 0
+      where n = length stacks
-                           return (t, s)
+  void $ repeatableSt 0 mods keyNext $ \t s -> if
-        choose n (t, s)
+    | t == keyPress && s == keyNext          -> modify succ
-              | t == keyPress   && s == keyNext  = io evt >>= choose (n+1)
+    | t == keyPress && s == keyPrev          -> modify pred
-              | t == keyPress   && s == keyPrev  = io evt >>= choose (n-1)
+    | t == keyPress && s `elem` [xK_0..xK_9] -> put (numKeyToN s)
-              | t == keyPress   && s `elem` [xK_0..xK_9] = io evt >>= choose (numKeyToN s)
+    | otherwise                              -> preview
-              | t == keyRelease && s `elem` mods = return ()
+  where numKeyToN = subtract 48 . read . show
-              | 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
 
 -- | Given a stack element and a stack, shift or insert the element (window)
 --   at the currently focused position.

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 ()
+{-# DEPRECATED repeatableAction "Use XMonad.Actions.Repeatable.repeatable" #-}
-repeatableAction mods pressHandler = do
+repeatableAction :: [KeySym] -> KeySym -> (EventType -> KeySym -> X ()) -> X ()
-  XConf {theRoot = root, display = d} <- ask
+repeatableAction = repeatable
-  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
 
 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
+  repeatable mods nextKey $
-  repeatableAction mods $
     runFirst
       [ handleKeyEvent keyPress nextKey $ focusIncrement 1
       , handleKeyEvent keyPress prevKey $ focusIncrement (-1)

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)

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