From b15c97b23006b2160eeb63721d2b17007d507151 Mon Sep 17 00:00:00 2001 From: "L. S. Leary" Date: Tue, 13 Dec 2022 18:16:51 +1300 Subject: [PATCH 1/8] Track Model--View Deviation in the X monad Currently, composability of X actions is broken, or at least flawed. The culprits are `windows` and a misplacement of responsibility. Every operation that needs to make changes to visible parts of the windowset must run them through the core model-rendering function, yet when time comes to compose those operations, there's no way to prevent intermediate states from being rendered. All of these additional renders are potentially expensive or otherwise deleterious to user experience; they can map and unmap windows, resize them multiple times, wake sleeping or swapped processes, etc. This can easily result in major slowdowns and visible artefacts such as windows jumping around, workspaces flashing past or borders flickering. The original design mitigated these issues by having `windows` accept composable windowset-modifying functions, however, this approach only works within the scope of a given action; it doesn't help to fuse unrelated actions. Further, interleaving any kind of layout operation or IO fundamentally breaks the paradigm. Some efforts have been made to remedy the problem at the contrib level; `X.A.MessageFeedback` and `X.U.PureX` in particular. However, they cannot be considered successful: they require actions to be rewritten in their paradigm, and must foist the task of transforming composable actions into "complete" ones onto the end user. This is not the righteous way. If we instead recognise that rendering the view is the responsibility of the core, a real solution becomes clear: we must take `windows` back from both the hands of the end user and the contrib module implementor. The way to do so transparently is to replace `windows` with a function that, rather than /performing/ a refresh, merely /requests/ one. In the paradigm of `X.U.PureX`, this is achieved by combining actions that produce `Any`, however, this approach does not suffice for our end: it breaks code by changing types, it forces changes in implementation to manually combine the `Any`s, and it interferes with actual return values. The proper tool to issue and combine monoidal values in a monadic context is the writer monad, hence we extend the X monad to write `Any`. --- src/XMonad/Core.hs | 31 +++++++++++++++++-------------- 1 file changed, 17 insertions(+), 14 deletions(-) diff --git a/src/XMonad/Core.hs b/src/XMonad/Core.hs index 631f847c..1ed2c24c 100644 --- a/src/XMonad/Core.hs +++ b/src/XMonad/Core.hs @@ -47,10 +47,9 @@ import qualified Control.Exception as E import Control.Applicative ((<|>), empty) import Control.Monad.Fail import Control.Monad.Fix (fix) -import Control.Monad.State +import Control.Monad.RWS import Control.Monad.Reader import Control.Monad (filterM, guard, void, when) -import Data.Semigroup import Data.Traversable (for) import Data.Time.Clock (UTCTime) import Data.Default.Class @@ -157,16 +156,19 @@ newtype ScreenDetail = SD { screenRect :: Rectangle } ------------------------------------------------------------------------ --- | The X monad, 'ReaderT' and 'StateT' transformers over 'IO' --- encapsulating the window manager configuration and state, --- respectively. +-- | The X monad; 'RWST' transformer over 'IO' encapsulating the window manager +-- configuration, model--view deviation and state, respectively. -- --- Dynamic components may be retrieved with 'get', static components --- with 'ask'. With newtype deriving we get readers and state monads --- instantiated on 'XConf' and 'XState' automatically. +-- Dynamic components may be retrieved with 'get' and 'listen', static +-- components with 'ask'. With newtype deriving we get readers, writers and +-- state monads instantiated on 'XConf', 'Any' and 'XState' automatically. -- -newtype X a = X (ReaderT XConf (StateT XState IO) a) - deriving (Functor, Applicative, Monad, MonadFail, MonadIO, MonadState XState, MonadReader XConf) +newtype X a = X (RWST XConf Any XState IO a) + deriving + ( Functor, Applicative, Monad, MonadFail, MonadIO + , MonadReader XConf, MonadWriter Any, MonadState XState + , MonadRWS XConf Any XState + ) deriving (Semigroup, Monoid) via Ap X a instance Default a => Default (X a) where @@ -184,9 +186,9 @@ instance Default a => Default (Query a) where def = return def -- | Run the 'X' monad, given a chunk of 'X' monad code, and an initial state --- Return the result, and final state -runX :: XConf -> XState -> X a -> IO (a, XState) -runX c st (X a) = runStateT (runReaderT a c) st +-- Return the result, final state and model--view deviation. +runX :: XConf -> XState -> X a -> IO (a, XState, Any) +runX c st (X rwsa) = runRWST rwsa c st -- | Run in the 'X' monad, and in case of exception, and catch it and log it -- to stderr, and run the error case. @@ -194,9 +196,10 @@ catchX :: X a -> X a -> X a catchX job errcase = do st <- get c <- ask - (a, s') <- io $ runX c st job `E.catch` \e -> case fromException e of + (a, s', mvd) <- io $ runX c st job `E.catch` \e -> case fromException e of Just (_ :: ExitCode) -> throw e _ -> do hPrint stderr e; runX c st errcase + tell mvd put s' return a From 2d6ef0f08797f5350c7983c887563d2be63cf654 Mon Sep 17 00:00:00 2001 From: "L. S. Leary" Date: Tue, 13 Dec 2022 18:17:13 +1300 Subject: [PATCH 2/8] MVDT: Propagate changes through Operations and Main `refresh` becomes our deviation-declaring, refresh-requesting operation, and its pair `norefresh` is introduced to deny such requests or mark them handled. As promised, we now make `windows` internal by renaming it `render`, providing a replacement that just modifies the windowset and issues `refresh`. `windowBracket` is cannibalised to become `handleRefresh`, catching requests and handling them through `render`. As with `windows`, we provide a replacement with the corresponding semantics under the new ways. Finally, we run the event handler and startup operations inside `handleRefresh`, completing the change of regime. /Note that this change will break any functionality actually requiring `windows` to perform an immediate refresh./ The solution would be to wrap any such use of `windows` in `handleRefresh`, but it currently offers poor support for nesting. This matter will be rectified in a later commit. --- src/XMonad/Main.hs | 25 ++++++++------- src/XMonad/Operations.hs | 69 ++++++++++++++++++++++++++++------------ 2 files changed, 63 insertions(+), 31 deletions(-) diff --git a/src/XMonad/Main.hs b/src/XMonad/Main.hs index c6913bb2..dc901759 100644 --- a/src/XMonad/Main.hs +++ b/src/XMonad/Main.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE BlockArguments #-} ---------------------------------------------------------------------------- -- | @@ -234,18 +235,20 @@ launch initxmc drs = do ws <- io $ scan dpy rootw - -- bootstrap the windowset, Operations.windows will identify all - -- the windows in winset as new and set initial properties for - -- those windows. Remove all windows that are no longer top-level - -- children of the root, they may have disappeared since - -- restarting. - let winset = maybe initialWinset windowset serializedSt - windows . const . foldr W.delete winset $ W.allWindows winset \\ ws + handleRefresh do + -- bootstrap the windowset, Operations.windows will identify all + -- the windows in winset as new and set initial properties for + -- those windows. Remove all windows that are no longer top-level + -- children of the root, they may have disappeared since + -- restarting. + let winset = maybe initialWinset windowset serializedSt + windows . const . foldr W.delete winset + $ W.allWindows winset \\ ws - -- manage the as-yet-unmanaged windows - mapM_ manage (ws \\ W.allWindows winset) + -- manage the as-yet-unmanaged windows + mapM_ manage (ws \\ W.allWindows winset) - userCode $ startupHook initxmc + userCode $ startupHook initxmc rrData <- io $ xrrQueryExtension dpy @@ -270,7 +273,7 @@ launch initxmc drs = do -- | Runs handleEventHook from the configuration and runs the default handler -- function if it returned True. handleWithHook :: Event -> X () -handleWithHook e = do +handleWithHook e = handleRefresh do evHook <- asks (handleEventHook . config) whenX (userCodeDef True $ getAll `fmap` evHook e) (handle e) diff --git a/src/XMonad/Operations.hs b/src/XMonad/Operations.hs index aa318e47..5676fed0 100644 --- a/src/XMonad/Operations.hs +++ b/src/XMonad/Operations.hs @@ -27,7 +27,8 @@ module XMonad.Operations ( setTopFocus, focus, isFixedSizeOrTransient, -- * Manage Windows - windows, refresh, rescreen, modifyWindowSet, windowBracket, windowBracket_, clearEvents, getCleanedScreenInfo, + windows, refresh, norefresh, handleRefresh, rescreen, modifyWindowSet, + windowBracket, windowBracket_, clearEvents, getCleanedScreenInfo, withFocused, withUnfocused, -- * Keyboard and Mouse @@ -66,6 +67,7 @@ import Data.Monoid (Endo(..),Any(..)) import Data.List (nub, (\\), find) import Data.Bits ((.|.), (.&.), complement, setBit, testBit) import Data.Function (on) +import Data.Functor ((<&>), ($>)) import Data.Ratio import qualified Data.Map as M import qualified Data.Set as S @@ -73,6 +75,7 @@ import qualified Data.Set as S import Control.Arrow (second) import Control.Monad.Fix (fix) import Control.Monad.Reader +import Control.Monad.Writer import Control.Monad.State import Control.Monad (forM, forM_, guard, join, unless, void, when) import qualified Control.Exception as C @@ -157,6 +160,18 @@ kill = withFocused killWindow -- | Modify the current window list with a pure function, and refresh windows :: (WindowSet -> WindowSet) -> X () windows f = do + modifyWindowSet f + refresh + +-- Handle an optional change to the model, rendering the currently visible +-- workspaces, as determined by the 'StackSet'. Also, set focus to the focused +-- window. +-- +-- This is our 'view' operation (MVC), in that it pretty prints our model +-- with X calls. +-- +render :: (WindowSet -> WindowSet) -> X () +render f = do XState { windowset = old } <- get let oldvisible = concatMap (W.integrate' . W.stack . W.workspace) $ W.current old : W.visible old newwindows = W.allWindows ws \\ W.allWindows old @@ -232,20 +247,34 @@ windows f = do modifyWindowSet :: (WindowSet -> WindowSet) -> X () modifyWindowSet f = modify $ \xst -> xst { windowset = f (windowset xst) } --- | Perform an @X@ action and check its return value against a predicate p. --- If p holds, unwind changes to the @WindowSet@ and replay them using @windows@. -windowBracket :: (a -> Bool) -> X a -> X a -windowBracket p action = withWindowSet $ \old -> do - a <- action - when (p a) . withWindowSet $ \new -> do - modifyWindowSet $ const old - windows $ const new +-- | Perform an @X@ action, updating the view if it's no longer consistent with +-- the model. +-- +-- __Warning__: This function does not support nesting, and consquently cannot +-- be used safely inside keybindings or any other user hook. Indeed, in its +-- current incarnation, @handleRefresh@ shouldn't be exposed at all. +-- However, making it internal would require us to move it (and @render@) into +-- "XMonad.Main" and deny any prospective extension the right to refresh. +-- As such, another solution is in the works. +-- +handleRefresh :: X a -> X a +handleRefresh action = norefresh . withWindowSet $ \old -> do + (a, Any dev) <- listen action + when dev . withWindowSet $ \new -> do + modifyWindowSet (const old) + render (const new) return a --- | Perform an @X@ action. If it returns @Any True@, unwind the --- changes to the @WindowSet@ and replay them using @windows@. This is --- a version of @windowBracket@ that discards the return value and --- handles an @X@ action that reports its need for refresh via @Any@. +-- | Perform an @X@ action and check its return value against a predicate @p@. +-- Request a refresh iff @p@ holds. +windowBracket :: (a -> Bool) -> X a -> X a +windowBracket p act = do + a <- norefresh act + when (p a) refresh $> a + +-- | Perform an @X@ action. If it returns @Any True@, request a refresh. +-- This is a version of @windowBracket@ that discards the return value and +-- handles an @X@ action that checks its own predicate internally. windowBracket_ :: X Any -> X () windowBracket_ = void . windowBracket getAny @@ -305,14 +334,14 @@ setInitialProperties w = asks normalBorder >>= \nb -> withDisplay $ \d -> do -- required by the border setting in 'windows' io $ setWindowBorder d w nb --- | Render the currently visible workspaces, as determined by --- the 'StackSet'. Also, set focus to the focused window. --- --- This is our 'view' operation (MVC), in that it pretty prints our model --- with X calls. --- +-- | Declare a deviation of the model from the view, hence request the view be +-- refreshed. refresh :: X () -refresh = windows id +refresh = tell (Any True) + +-- | Catch and discard any 'refresh' requests issued by an action. +norefresh :: X a -> X a +norefresh act = pass $ act <&> \a -> (a, mempty) -- | Remove all events of a given type from the event queue. clearEvents :: EventMask -> X () From 33257065f8c0c50990de8d7a91db7bca4eb15c07 Mon Sep 17 00:00:00 2001 From: "L. S. Leary" Date: Tue, 13 Dec 2022 18:17:23 +1300 Subject: [PATCH 3/8] MVDT: Declare every deviation; deprecate the undeclaring Under the new regime, an operation should issue `refresh` if it may directly cause the model to deviate from the view, and should avoid doing so when it knows it will not. Hence: * `updateLayout` issues `refresh` iff the target workspace is visible. For reusability, this workspace-updating logic is implemented as the more general `respace`. * `modifyWindowSet` is deprecated. * `sendMessageWithNoRefresh` is replaced by `messageWorkspace` and deprecated. * `broadcastMessage` may now (indirectly) issue `refresh`. `windowBracket` and co. were originally introduced so that windowset changes made in `sendMessage` would be properly handled in the accompanying refresh. The approach has since been adopted for use in `handleRefresh`, so these functions are no longer necessary and don't belong in the core. As such, `sendMessage` is simplified and the "bracket" functions are deprecated. --- src/XMonad/Operations.hs | 55 +++++++++++++++++++++++++--------------- 1 file changed, 35 insertions(+), 20 deletions(-) diff --git a/src/XMonad/Operations.hs b/src/XMonad/Operations.hs index 5676fed0..28a30955 100644 --- a/src/XMonad/Operations.hs +++ b/src/XMonad/Operations.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BlockArguments #-} -- -------------------------------------------------------------------------- -- | @@ -27,8 +28,9 @@ module XMonad.Operations ( setTopFocus, focus, isFixedSizeOrTransient, -- * Manage Windows - windows, refresh, norefresh, handleRefresh, rescreen, modifyWindowSet, - windowBracket, windowBracket_, clearEvents, getCleanedScreenInfo, + windows, respace, refresh, norefresh, handleRefresh, rescreen, + modifyWindowSet, windowBracket, windowBracket_, + clearEvents, getCleanedScreenInfo, withFocused, withUnfocused, -- * Keyboard and Mouse @@ -37,7 +39,7 @@ module XMonad.Operations ( setButtonGrab, setFocusX, cacheNumlockMask, mkGrabs, -- * Messages - sendMessage, broadcastMessage, sendMessageWithNoRefresh, + sendMessage, messageWorkspace, broadcastMessage, sendMessageWithNoRefresh, sendRestart, sendReplace, -- * Save and Restore State @@ -160,9 +162,18 @@ kill = withFocused killWindow -- | Modify the current window list with a pure function, and refresh windows :: (WindowSet -> WindowSet) -> X () windows f = do - modifyWindowSet f + modify \xst -> xst{ windowset = f (windowset xst) } refresh +-- | Modify a workspace with a pure function, refreshing if visible +respace :: WorkspaceId -> (WindowSpace -> WindowSpace) -> X () +respace i f = do + visibles <- gets (fmap (W.tag . W.workspace) . W.screens . windowset) + runOnWorkspaces \ww -> pure if W.tag ww == i + then f ww + else ww + when (i `elem` visibles) refresh + -- Handle an optional change to the model, rendering the currently visible -- workspaces, as determined by the 'StackSet'. Also, set focus to the focused -- window. @@ -189,7 +200,7 @@ render f = do -- notify non visibility let tags_oldvisible = map (W.tag . W.workspace) $ W.current old : W.visible old gottenhidden = filter (flip elem tags_oldvisible . W.tag) $ W.hidden ws - mapM_ (sendMessageWithNoRefresh Hide) gottenhidden + mapM_ (messageWorkspace Hide) gottenhidden -- for each workspace, layout the currently visible workspaces let allscreens = W.screens ws @@ -244,8 +255,9 @@ render f = do asks (logHook . config) >>= userCodeDef () -- | Modify the @WindowSet@ in state with no special handling. +{-# DEPRECATED modifyWindowSet "Use `windows` and `norefresh`." #-} modifyWindowSet :: (WindowSet -> WindowSet) -> X () -modifyWindowSet f = modify $ \xst -> xst { windowset = f (windowset xst) } +modifyWindowSet = norefresh . windows -- | Perform an @X@ action, updating the view if it's no longer consistent with -- the model. @@ -261,12 +273,13 @@ handleRefresh :: X a -> X a handleRefresh action = norefresh . withWindowSet $ \old -> do (a, Any dev) <- listen action when dev . withWindowSet $ \new -> do - modifyWindowSet (const old) - render (const new) + windows (const old) + render (const new) return a -- | Perform an @X@ action and check its return value against a predicate @p@. -- Request a refresh iff @p@ holds. +{-# DEPRECATED windowBracket "Use `norefresh` and `refresh`." #-} windowBracket :: (a -> Bool) -> X a -> X a windowBracket p act = do a <- norefresh act @@ -275,6 +288,7 @@ windowBracket p act = do -- | Perform an @X@ action. If it returns @Any True@, request a refresh. -- This is a version of @windowBracket@ that discards the return value and -- handles an @X@ action that checks its own predicate internally. +{-# DEPRECATED windowBracket_ "Use `norefresh` and `refresh`." #-} windowBracket_ :: X Any -> X () windowBracket_ = void . windowBracket getAny @@ -509,38 +523,39 @@ mkGrabs ks = withDisplay $ \dpy -> do -- | Throw a message to the current 'LayoutClass' possibly modifying how we -- layout the windows, in which case changes are handled through a refresh. sendMessage :: Message a => a -> X () -sendMessage a = windowBracket_ $ do +sendMessage a = do w <- gets $ W.workspace . W.current . windowset ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing whenJust ml' $ \l' -> - modifyWindowSet $ \ws -> ws { W.current = (W.current ws) + windows \ws -> ws { W.current = (W.current ws) { W.workspace = (W.workspace $ W.current ws) { W.layout = l' }}} - return (Any $ isJust ml') --- | Send a message to all layouts, without refreshing. +-- | Send a message to all layouts. broadcastMessage :: Message a => a -> X () -broadcastMessage a = withWindowSet $ \ws -> do +broadcastMessage a = do -- this is O(n²), but we can't really fix this as there's code in -- xmonad-contrib that touches the windowset during handleMessage -- (returning Nothing for changes to not get overwritten), so we -- unfortunately need to do this one by one and persist layout states -- of each workspace separately) - let c = W.workspace . W.current $ ws - v = map W.workspace . W.visible $ ws - h = W.hidden ws - mapM_ (sendMessageWithNoRefresh a) (c : v ++ h) + gets (W.workspaces . windowset) >>= mapM_ (messageWorkspace a) -- | Send a message to a layout, without refreshing. +{-# DEPRECATED sendMessageWithNoRefresh "Use `norefresh` and `messageWorkspace`." #-} sendMessageWithNoRefresh :: Message a => a -> WindowSpace -> X () -sendMessageWithNoRefresh a w = +sendMessageWithNoRefresh a w = norefresh (messageWorkspace a w) + +-- | Message the given workspace. +messageWorkspace :: Message a => a -> WindowSpace -> X () +messageWorkspace a w = handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing >>= updateLayout (W.tag w) -- | Update the layout field of a workspace. updateLayout :: WorkspaceId -> Maybe (Layout Window) -> X () -updateLayout i ml = whenJust ml $ \l -> - runOnWorkspaces $ \ww -> return $ if W.tag ww == i then ww { W.layout = l} else ww +updateLayout i ml = whenJust ml \l -> + respace i \ww -> ww{ W.layout = l } -- | Set the layout of the currently viewed workspace. setLayout :: Layout Window -> X () From 2fff2a023912e585b67ae1cdf709574f0c86ca84 Mon Sep 17 00:00:00 2001 From: "L. S. Leary" Date: Tue, 13 Dec 2022 18:17:34 +1300 Subject: [PATCH 4/8] Clean up sendMessage, setLayout & manage There was unnecessary noise and duplication in these functions. * `sendMessage`: Rewrite via `messageWorkspace` * `setLayout`: Rewrite via `sendMessage` and `updateLayout` * `manage`: Remove code equivalent to `W.view (W.currentTag ws) ws` The `sendMessage` rewrite also fixes a corner case misbehaviour: previously, if message handling resulted in another workspace taking focus, the layout update would mangle that workspace. This is no longer the case. --- src/XMonad/Operations.hs | 20 +++++++------------- 1 file changed, 7 insertions(+), 13 deletions(-) diff --git a/src/XMonad/Operations.hs b/src/XMonad/Operations.hs index 28a30955..b539ea83 100644 --- a/src/XMonad/Operations.hs +++ b/src/XMonad/Operations.hs @@ -120,13 +120,12 @@ manage w = whenX (not <$> isClient w) $ withDisplay $ \d -> do = W.RationalRect (0.5 - wid/2) (0.5 - h/2) wid h adjust r = r - f ws | shouldFloat = W.float w (adjust rr) . W.insertUp w . W.view i $ ws - | otherwise = W.insertUp w ws - where i = W.tag $ W.workspace $ W.current ws + f | shouldFloat = W.float w (adjust rr) + | otherwise = id mh <- asks (manageHook . config) g <- appEndo <$> userCodeDef (Endo id) (runQuery mh w) - windows (g . f) + windows (g . f . W.insertUp w) -- | A window no longer exists; remove it from the window -- list, on whatever workspace it is. @@ -524,12 +523,7 @@ mkGrabs ks = withDisplay $ \dpy -> do -- layout the windows, in which case changes are handled through a refresh. sendMessage :: Message a => a -> X () sendMessage a = do - w <- gets $ W.workspace . W.current . windowset - ml' <- handleMessage (W.layout w) (SomeMessage a) `catchX` return Nothing - whenJust ml' $ \l' -> - windows \ws -> ws { W.current = (W.current ws) - { W.workspace = (W.workspace $ W.current ws) - { W.layout = l' }}} + gets (W.workspace . W.current . windowset) >>= messageWorkspace a -- | Send a message to all layouts. broadcastMessage :: Message a => a -> X () @@ -560,9 +554,9 @@ updateLayout i ml = whenJust ml \l -> -- | Set the layout of the currently viewed workspace. setLayout :: Layout Window -> X () setLayout l = do - ss@W.StackSet{ W.current = c@W.Screen{ W.workspace = ws }} <- gets windowset - handleMessage (W.layout ws) (SomeMessage ReleaseResources) - windows $ const $ ss{ W.current = c{ W.workspace = ws{ W.layout = l } } } + sendMessage ReleaseResources + ct <- gets (W.currentTag . windowset) + updateLayout ct (Just l) -- | Signal xmonad to restart itself. sendRestart :: IO () From 4f50c8420d03e2f46eee9f00d5a80a711025b6c1 Mon Sep 17 00:00:00 2001 From: "L. S. Leary" Date: Tue, 13 Dec 2022 18:17:53 +1300 Subject: [PATCH 5/8] Support nesting of handleRefresh `render` requires the previously rendered state of the model---the current state of the view---to judge changes against. Originally, this was done by taking the windowset for that state and requiring changes be provided in the form of a function. Under that regime, the windowset is not a fine grained internal model---its merely a log of the view which shouldn't be exposed for editing outside of `render`. `handleRefresh` (previously `windowBracket`) used a cute trick to buy granularity within a child action by grabbing the "old" and the "new" copies of the windowset that `render` needs before and after the action runs. However, such a trick has its limits. In particular, it does not support nesting---a refresh in the child action invalidates the "old" copy. The solution is straightforward: separately from our model, keep an actual log of the state of the view, and don't expose it for editing. Hence it does not appear in the `XState`, but is secreted away in an `IORef` in a new opaque `Internal` portion of the `XConf`. --- src/XMonad/Core.hs | 2 ++ src/XMonad/Internal/Core.hs | 32 +++++++++++++++++++++++++++++++ src/XMonad/Internal/Operations.hs | 18 +++++++++++++++++ src/XMonad/Main.hs | 6 +++++- src/XMonad/Operations.hs | 31 ++++++++++-------------------- xmonad.cabal | 2 ++ 6 files changed, 69 insertions(+), 22 deletions(-) create mode 100644 src/XMonad/Internal/Core.hs create mode 100644 src/XMonad/Internal/Operations.hs diff --git a/src/XMonad/Core.hs b/src/XMonad/Core.hs index 1ed2c24c..5044b5da 100644 --- a/src/XMonad/Core.hs +++ b/src/XMonad/Core.hs @@ -39,6 +39,7 @@ module XMonad.Core ( ManageHook, Query(..), runQuery, Directories'(..), Directories, getDirectories, ) where +import XMonad.Internal.Core (Internal) import XMonad.StackSet hiding (modify) import Prelude @@ -106,6 +107,7 @@ data XConf = XConf -- the event currently being processed , currentEvent :: !(Maybe Event) -- ^ event currently being processed , directories :: !Directories -- ^ directories to use + , internal :: !(Internal WindowSet) -- ^ a hiding place for internals } -- todo, better name diff --git a/src/XMonad/Internal/Core.hs b/src/XMonad/Internal/Core.hs new file mode 100644 index 00000000..9f401c14 --- /dev/null +++ b/src/XMonad/Internal/Core.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module XMonad.Internal.Core + ( Internal, unsafeMakeInternal + , readView, unsafeWriteView + ) where + +import Data.IORef (IORef, newIORef, readIORef, writeIORef) + +-- | An opaque data type for holding state and configuration that isn't to be +-- laid bare to the world outside, nor even to the rest of the package if we +-- can help it. +newtype Internal model = Internal + { view :: IORef model -- ^ An 'IORef' to which we log the state of the view. + } + +-- | The ability to construct an 'Internal' allows one to play tricks with +-- 'local'. +unsafeMakeInternal :: model -> IO (Internal model) +unsafeMakeInternal model = do + viewRef <- newIORef model + pure Internal + { view = viewRef + } + +readView :: Internal model -> IO model +readView Internal{view} = readIORef view + +-- | The 'view' ref can only be safely written to with a just-rendered model. +unsafeWriteView :: Internal model -> model -> IO () +unsafeWriteView Internal{view} = writeIORef view + diff --git a/src/XMonad/Internal/Operations.hs b/src/XMonad/Internal/Operations.hs new file mode 100644 index 00000000..d9efa3da --- /dev/null +++ b/src/XMonad/Internal/Operations.hs @@ -0,0 +1,18 @@ + +module XMonad.Internal.Operations + ( rendered, unsafeLogView + ) where + +import Control.Monad.Reader (asks) +import XMonad.Internal.Core (readView, unsafeWriteView) +import XMonad.Core (X, WindowSet, internal, io, withWindowSet) + +-- | Examine the 'WindowSet' that's currently rendered. +rendered :: X WindowSet +rendered = asks internal >>= io . readView + +-- | See 'unsafeWriteView'. +unsafeLogView :: X () +unsafeLogView = do + i <- asks internal + withWindowSet (io . unsafeWriteView i) diff --git a/src/XMonad/Main.hs b/src/XMonad/Main.hs index dc901759..826b3f92 100644 --- a/src/XMonad/Main.hs +++ b/src/XMonad/Main.hs @@ -34,6 +34,7 @@ import Data.Monoid (getAll) import Graphics.X11.Xlib hiding (refreshKeyboardMapping) import Graphics.X11.Xlib.Extras +import XMonad.Internal.Core (unsafeMakeInternal) import XMonad.Core import qualified XMonad.Config as Default import XMonad.StackSet (new, floating, member) @@ -192,7 +193,9 @@ launch initxmc drs = do initialWinset = let padToLen n xs = take (max n (length xs)) $ xs ++ repeat "" in new layout (padToLen (length xinesc) (workspaces xmc)) $ map SD xinesc - cf = XConf + int <- unsafeMakeInternal initialWinset + + let cf = XConf { display = dpy , config = xmc , theRoot = rootw @@ -204,6 +207,7 @@ launch initxmc drs = do , mousePosition = Nothing , currentEvent = Nothing , directories = drs + , internal = int } st = XState diff --git a/src/XMonad/Operations.hs b/src/XMonad/Operations.hs index b539ea83..682c8c56 100644 --- a/src/XMonad/Operations.hs +++ b/src/XMonad/Operations.hs @@ -28,7 +28,7 @@ module XMonad.Operations ( setTopFocus, focus, isFixedSizeOrTransient, -- * Manage Windows - windows, respace, refresh, norefresh, handleRefresh, rescreen, + windows, respace, refresh, norefresh, handleRefresh, rendered, rescreen, modifyWindowSet, windowBracket, windowBracket_, clearEvents, getCleanedScreenInfo, withFocused, withUnfocused, @@ -63,6 +63,7 @@ module XMonad.Operations ( import XMonad.Core import XMonad.Layout (Full(..)) import qualified XMonad.StackSet as W +import XMonad.Internal.Operations (rendered, unsafeLogView) import Data.Maybe import Data.Monoid (Endo(..),Any(..)) @@ -173,19 +174,17 @@ respace i f = do else ww when (i `elem` visibles) refresh --- Handle an optional change to the model, rendering the currently visible --- workspaces, as determined by the 'StackSet'. Also, set focus to the focused --- window. +-- Handle any changes to the model, rendering the currently visible workspaces, +-- as determined by the 'StackSet'. Also, set focus to the focused window. -- -- This is our 'view' operation (MVC), in that it pretty prints our model -- with X calls. -- -render :: (WindowSet -> WindowSet) -> X () -render f = do - XState { windowset = old } <- get +render :: X () +render = withWindowSet \ws -> do + old <- rendered let oldvisible = concatMap (W.integrate' . W.stack . W.workspace) $ W.current old : W.visible old newwindows = W.allWindows ws \\ W.allWindows old - ws = f old XConf { display = d , normalBorder = nbc, focusedBorder = fbc } <- ask mapM_ setInitialProperties newwindows @@ -251,6 +250,7 @@ render f = do isMouseFocused <- asks mouseFocused unless isMouseFocused $ clearEvents enterWindowMask + unsafeLogView asks (logHook . config) >>= userCodeDef () -- | Modify the @WindowSet@ in state with no special handling. @@ -260,21 +260,10 @@ modifyWindowSet = norefresh . windows -- | Perform an @X@ action, updating the view if it's no longer consistent with -- the model. --- --- __Warning__: This function does not support nesting, and consquently cannot --- be used safely inside keybindings or any other user hook. Indeed, in its --- current incarnation, @handleRefresh@ shouldn't be exposed at all. --- However, making it internal would require us to move it (and @render@) into --- "XMonad.Main" and deny any prospective extension the right to refresh. --- As such, another solution is in the works. --- handleRefresh :: X a -> X a -handleRefresh action = norefresh . withWindowSet $ \old -> do +handleRefresh action = norefresh do (a, Any dev) <- listen action - when dev . withWindowSet $ \new -> do - windows (const old) - render (const new) - return a + when dev render $> a -- | Perform an @X@ action and check its return value against a predicate @p@. -- Request a refresh iff @p@ holds. diff --git a/xmonad.cabal b/xmonad.cabal index f90bab0b..5a6ad19e 100644 --- a/xmonad.cabal +++ b/xmonad.cabal @@ -64,6 +64,8 @@ library XMonad.Operations XMonad.StackSet other-modules: Paths_xmonad + XMonad.Internal.Core + XMonad.Internal.Operations hs-source-dirs: src build-depends: base >= 4.11 && < 5 , X11 >= 1.10 && < 1.11 From 506b13c3463b64aef3b8e8dbf9bb11e9427cee9f Mon Sep 17 00:00:00 2001 From: "L. S. Leary" Date: Tue, 13 Dec 2022 18:18:17 +1300 Subject: [PATCH 6/8] Document MVDT changes; declare authorship --- CHANGES.md | 19 +++++++++++++++++++ xmonad.cabal | 3 ++- 2 files changed, 21 insertions(+), 1 deletion(-) diff --git a/CHANGES.md b/CHANGES.md index f26f2a6a..07f63f0f 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -4,10 +4,29 @@ ### Breaking Changes +* MVDT: + + * The type of `runX` has changed. + + * `windows` no longer performs an immediate refresh, but requests one. + That request is handled by `handleRefresh`. + + * Deprecated `modifyWindowSet`, `windowBracket`, `windowBracket_` and + `sendMessageWithNoRefresh`. + + * Extended `XConf` with a new `internal` field. + * Dropped support for GHC 8.4. ### Enhancements +* MVDT: + + * X actions can now be combined without performing spurious refreshes. + + * New operations: `norefresh`, `handleRefresh`, `respace`, + `messageWorkspace` and `rendered`. + * Exported `sendRestart` and `sendReplace` from `XMonad.Operations`. * Exported `buildLaunch` from `XMonad.Main`. diff --git a/xmonad.cabal b/xmonad.cabal index 5a6ad19e..449b4f55 100644 --- a/xmonad.cabal +++ b/xmonad.cabal @@ -25,7 +25,8 @@ author: Spencer Janssen, Don Stewart, Adam Vogt, David Roundy, Jason Jens Petersen, Joey Hess, Jonne Ransijn, Josh Holland, Khudyakov Alexey, Klaus Weidner, Michael G. Sloan, Mikkel Christiansen, Nicolas Dudebout, Ondřej Súkup, Paul Hebble, Shachaf Ben-Kiki, Siim Põder, Tim McIver, - Trevor Elliott, Wouter Swierstra, Conrad Irwin, Tim Thelion, Tony Zorman + Trevor Elliott, Wouter Swierstra, Conrad Irwin, Tim Thelion, Tony Zorman, + L. S. Leary maintainer: xmonad@haskell.org tested-with: GHC == 8.6.5 || == 8.8.4 || == 8.10.7 || == 9.0.2 || == 9.2.5 || == 9.4.3 category: System From 2bf9487284d4cbd70b7fc1f56146090d8b8a669f Mon Sep 17 00:00:00 2001 From: "L. S. Leary" Date: Tue, 13 Dec 2022 18:24:02 +1300 Subject: [PATCH 7/8] Purify the unclean by generalising type signatures Many operations were previously impure due to direct or indirect use of the old `windows`, now `render`. Due to MVDT, we can now purify them. To do so, we generalise their type signatures away from `X` to arbitrary monads satisfying the relevant mtl constraints. This has further advantages in terms of code reuse (e.g. in `X.U.PureX`) and possibly in testing. However, it also causes some breakage---bindings that previously type checked without a signature may now need `FlexibleContexts` to do so. --- CHANGES.md | 10 ++++++++++ src/XMonad/Core.hs | 20 +++++++++++--------- src/XMonad/ManageHook.hs | 2 +- src/XMonad/Operations.hs | 40 ++++++++++++++++++++++------------------ 4 files changed, 44 insertions(+), 28 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 07f63f0f..30d6cbbf 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -16,6 +16,14 @@ * Extended `XConf` with a new `internal` field. + * Newly generalised functions mean that bindings which previously type + checked without a signature may now require a pragma at the head of + `xmonad.hs` to do so. + + ```haskell + {-# LANGUAGE FlexibleContexts #-} + ``` + * Dropped support for GHC 8.4. ### Enhancements @@ -27,6 +35,8 @@ * New operations: `norefresh`, `handleRefresh`, `respace`, `messageWorkspace` and `rendered`. + * Various operations have been generalised and are now pure. + * Exported `sendRestart` and `sendReplace` from `XMonad.Operations`. * Exported `buildLaunch` from `XMonad.Main`. diff --git a/src/XMonad/Core.hs b/src/XMonad/Core.hs index 5044b5da..752b4cb1 100644 --- a/src/XMonad/Core.hs +++ b/src/XMonad/Core.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -52,6 +53,7 @@ import Control.Monad.RWS import Control.Monad.Reader import Control.Monad (filterM, guard, void, when) import Data.Traversable (for) +import Data.Foldable (for_) import Data.Time.Clock (UTCTime) import Data.Default.Class import System.Environment (lookupEnv) @@ -219,11 +221,11 @@ userCodeDef defValue a = fromMaybe defValue <$> userCode a -- Convenient wrappers to state -- | Run a monad action with the current display settings -withDisplay :: (Display -> X a) -> X a +withDisplay :: MonadReader XConf m => (Display -> m a) -> m a withDisplay f = asks display >>= f -- | Run a monadic action with the current stack set -withWindowSet :: (WindowSet -> X a) -> X a +withWindowSet :: MonadState XState m => (WindowSet -> m a) -> m a withWindowSet f = gets windowset >>= f -- | Safely access window attributes. @@ -233,7 +235,7 @@ withWindowAttributes dpy win f = do catchX (whenJust wa f) (return ()) -- | True if the given window is the root window -isRoot :: Window -> X Bool +isRoot :: MonadReader XConf m => Window -> m Bool isRoot w = asks $ (w ==) . theRoot -- | Wrapper for the common case of atom internment @@ -471,11 +473,11 @@ xmessage msg = void . xfork $ do -- | This is basically a map function, running a function in the 'X' monad on -- each workspace with the output of that function being the modified workspace. -runOnWorkspaces :: (WindowSpace -> X WindowSpace) -> X () +runOnWorkspaces :: MonadState XState m => (WindowSpace -> m WindowSpace) -> m () runOnWorkspaces job = do ws <- gets windowset h <- mapM job $ hidden ws - c:v <- mapM (\s -> (\w -> s { workspace = w}) <$> job (workspace s)) + ~(c:v) <- mapM (\s -> (\w -> s { workspace = w}) <$> job (workspace s)) $ current ws : visible ws modify $ \s -> s { windowset = ws { current = c, visible = v, hidden = h } } @@ -755,11 +757,11 @@ recompile dirs force = io $ do pure True -- | Conditionally run an action, using a @Maybe a@ to decide. -whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () -whenJust mg f = maybe (return ()) f mg +whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () +whenJust = for_ --- | Conditionally run an action, using a 'X' event to decide -whenX :: X Bool -> X () -> X () +-- | Conditionally run an action, using an 'm' action to decide +whenX :: Monad m => m Bool -> m () -> m () whenX a f = a >>= \b -> when b f -- | A 'trace' for the 'X' monad. Logs a string to stderr. The result may diff --git a/src/XMonad/ManageHook.hs b/src/XMonad/ManageHook.hs index 8e46a904..8c764549 100644 --- a/src/XMonad/ManageHook.hs +++ b/src/XMonad/ManageHook.hs @@ -51,7 +51,7 @@ infix 0 --> p --> f = p >>= \b -> if b then f else return mempty -- | @q =? x@. if the result of @q@ equals @x@, return 'True'. -(=?) :: Eq a => Query a -> a -> Query Bool +(=?) :: (Functor f, Eq a) => f a -> a -> f Bool q =? x = fmap (== x) q infixr 3 <&&>, <||> diff --git a/src/XMonad/Operations.hs b/src/XMonad/Operations.hs index 682c8c56..67c16894 100644 --- a/src/XMonad/Operations.hs +++ b/src/XMonad/Operations.hs @@ -77,9 +77,7 @@ import qualified Data.Set as S import Control.Arrow (second) import Control.Monad.Fix (fix) -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Monad.State +import Control.Monad.RWS import Control.Monad (forM, forM_, guard, join, unless, void, when) import qualified Control.Exception as C @@ -131,7 +129,7 @@ manage w = whenX (not <$> isClient w) $ withDisplay $ \d -> do -- | A window no longer exists; remove it from the window -- list, on whatever workspace it is. -- -unmanage :: Window -> X () +unmanage :: (MonadWriter Any m, MonadState XState m) => Window -> m () unmanage = windows . W.delete -- | Kill the specified window. If we do kill it, we'll get a @@ -160,13 +158,17 @@ kill = withFocused killWindow -- Managing windows -- | Modify the current window list with a pure function, and refresh -windows :: (WindowSet -> WindowSet) -> X () +windows + :: (MonadWriter Any m, MonadState XState m) + => (WindowSet -> WindowSet) -> m () windows f = do modify \xst -> xst{ windowset = f (windowset xst) } refresh -- | Modify a workspace with a pure function, refreshing if visible -respace :: WorkspaceId -> (WindowSpace -> WindowSpace) -> X () +respace + :: (MonadWriter Any m, MonadState XState m) + => WorkspaceId -> (WindowSpace -> WindowSpace) -> m () respace i f = do visibles <- gets (fmap (W.tag . W.workspace) . W.screens . windowset) runOnWorkspaces \ww -> pure if W.tag ww == i @@ -338,11 +340,11 @@ setInitialProperties w = asks normalBorder >>= \nb -> withDisplay $ \d -> do -- | Declare a deviation of the model from the view, hence request the view be -- refreshed. -refresh :: X () +refresh :: MonadWriter Any m => m () refresh = tell (Any True) -- | Catch and discard any 'refresh' requests issued by an action. -norefresh :: X a -> X a +norefresh :: MonadWriter w m => m a -> m a norefresh act = pass $ act <&> \a -> (a, mempty) -- | Remove all events of a given type from the event queue. @@ -424,7 +426,7 @@ setTopFocus = withWindowSet $ maybe (setFocusX =<< asks theRoot) setFocusX . W.p -- | Set focus explicitly to window 'w' if it is managed by us, or root. -- This happens if X notices we've moved the mouse (and perhaps moved -- the mouse to a new screen). -focus :: Window -> X () +focus :: MonadRWS XConf Any XState m => Window -> m () focus w = local (\c -> c { mouseFocused = True }) $ withWindowSet $ \s -> do let stag = W.tag . W.workspace curr = stag $ W.current s @@ -536,7 +538,9 @@ messageWorkspace a w = updateLayout (W.tag w) -- | Update the layout field of a workspace. -updateLayout :: WorkspaceId -> Maybe (Layout Window) -> X () +updateLayout + :: (MonadState XState m, MonadWriter Any m) + => WorkspaceId -> Maybe (Layout Window) -> m () updateLayout i ml = whenJust ml \l -> respace i \ww -> ww{ W.layout = l } @@ -604,33 +608,33 @@ replace dpy dflt rootw = do -- Utilities -- | Return workspace visible on screen @sc@, or 'Nothing'. -screenWorkspace :: ScreenId -> X (Maybe WorkspaceId) +screenWorkspace :: MonadState XState m => ScreenId -> m (Maybe WorkspaceId) screenWorkspace sc = withWindowSet $ return . W.lookupWorkspace sc -- | Apply an 'X' operation to the currently focused window, if there is one. -withFocused :: (Window -> X ()) -> X () +withFocused :: MonadState XState m => (Window -> m ()) -> m () withFocused f = withWindowSet $ \w -> whenJust (W.peek w) f -- | Apply an 'X' operation to all unfocused windows on the current workspace, if there are any. -withUnfocused :: (Window -> X ()) -> X () +withUnfocused :: MonadState XState m => (Window -> m ()) -> m () withUnfocused f = withWindowSet $ \ws -> whenJust (W.peek ws) $ \w -> let unfocusedWindows = filter (/= w) $ W.index ws in mapM_ f unfocusedWindows -- | Is the window is under management by xmonad? -isClient :: Window -> X Bool +isClient :: MonadState XState m => Window -> m Bool isClient w = withWindowSet $ return . W.member w -- | Combinations of extra modifier masks we need to grab keys\/buttons for. -- (numlock and capslock) -extraModifiers :: X [KeyMask] +extraModifiers :: MonadState XState m => m [KeyMask] extraModifiers = do nlm <- gets numberlockMask return [0, nlm, lockMask, nlm .|. lockMask ] -- | Strip numlock\/capslock from a mask. -cleanMask :: KeyMask -> X KeyMask +cleanMask :: MonadState XState m => KeyMask -> m KeyMask cleanMask km = do nlm <- gets numberlockMask return (complement (nlm .|. lockMask) .&. km) @@ -758,8 +762,8 @@ floatLocation w = fi = fromIntegral -- | Given a point, determine the screen (if any) that contains it. -pointScreen :: Position -> Position - -> X (Maybe (W.Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail)) +pointScreen :: MonadState XState m => Position -> Position + -> m (Maybe (W.Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail)) pointScreen x y = withWindowSet $ return . find p . W.screens where p = pointWithin x y . screenRect . W.screenDetail From 7e036772b1f46ba7ef06f137d140e9f3f7e681bb Mon Sep 17 00:00:00 2001 From: "L. S. Leary" Date: Sun, 18 Dec 2022 01:47:13 +1300 Subject: [PATCH 8/8] Deprecate runOnWorkspaces in favour of traverseWorkspaces `runOnWorkspaces` was a questionable existence in various ways: * It traversed the workspaces in a unexpected, nonstandard order. * It needlessly utilised a non-exhaustive pattern match, abusing first `MonadFail` then irrefutability to evade warning. * It was used nowhere in contrib, once in core---that sole use with a pure function. * Even after generalisation, it still has a bad type, both misleading and lacking in parametricity. Specialising the `StackSet` traversal to the `WindowSet` in `XState` gives the function too much power, and suggests that it's using that power to provide special support for `WindowSet` modifications when in fact it does no such thing. To resolve these issues, the workspace traversal logic is written as `traverseWorkspaces` in `X.StackSet`, and `mapWorkspaces` written atop that via `Identity`. The latter then replaces the sole use of `runOnWorkspaces`, condemning it to deprecation. --- CHANGES.md | 4 ++++ src/XMonad/Core.hs | 11 +++++------ src/XMonad/Operations.hs | 2 +- src/XMonad/StackSet.hs | 21 +++++++++++++++++++++ 4 files changed, 31 insertions(+), 7 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 30d6cbbf..b652a19f 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -4,6 +4,8 @@ ### Breaking Changes +* Deprecated `runOnWorkspaces`. + * MVDT: * The type of `runX` has changed. @@ -28,6 +30,8 @@ ### Enhancements +* X.StackSet now provides `mapWorkspaces` and `traverseWorkspaces`. + * MVDT: * X actions can now be combined without performing spurious refreshes. diff --git a/src/XMonad/Core.hs b/src/XMonad/Core.hs index 752b4cb1..134e67b1 100644 --- a/src/XMonad/Core.hs +++ b/src/XMonad/Core.hs @@ -9,6 +9,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE BlockArguments #-} ----------------------------------------------------------------------------- -- | @@ -473,13 +474,11 @@ xmessage msg = void . xfork $ do -- | This is basically a map function, running a function in the 'X' monad on -- each workspace with the output of that function being the modified workspace. +{-# DEPRECATED runOnWorkspaces "Use `traverseWorkspaces`." #-} runOnWorkspaces :: MonadState XState m => (WindowSpace -> m WindowSpace) -> m () -runOnWorkspaces job = do - ws <- gets windowset - h <- mapM job $ hidden ws - ~(c:v) <- mapM (\s -> (\w -> s { workspace = w}) <$> job (workspace s)) - $ current ws : visible ws - modify $ \s -> s { windowset = ws { current = c, visible = v, hidden = h } } +runOnWorkspaces job = withWindowSet \ws -> do + ws' <- traverseWorkspaces job ws + modify \st -> st{ windowset = ws' } -- | All the directories that xmonad will use. They will be used for -- the following purposes: diff --git a/src/XMonad/Operations.hs b/src/XMonad/Operations.hs index 67c16894..1d52cd7a 100644 --- a/src/XMonad/Operations.hs +++ b/src/XMonad/Operations.hs @@ -171,7 +171,7 @@ respace => WorkspaceId -> (WindowSpace -> WindowSpace) -> m () respace i f = do visibles <- gets (fmap (W.tag . W.workspace) . W.screens . windowset) - runOnWorkspaces \ww -> pure if W.tag ww == i + norefresh . windows $ W.mapWorkspaces \ww -> if W.tag ww == i then f ww else ww when (i `elem` visibles) refresh diff --git a/src/XMonad/StackSet.hs b/src/XMonad/StackSet.hs index 53c7cd8b..a53805bb 100644 --- a/src/XMonad/StackSet.hs +++ b/src/XMonad/StackSet.hs @@ -41,6 +41,7 @@ module XMonad.StackSet ( -- * Modifying the stackset -- $modifyStackset insertUp, delete, delete', filter, + mapWorkspaces, traverseWorkspaces, -- * Setting the master window -- $settingMW swapUp, swapDown, swapMaster, shiftMaster, modify, modify', float, sink, -- needed by users @@ -54,6 +55,8 @@ module XMonad.StackSet ( import Prelude hiding (filter) import Control.Applicative.Backwards (Backwards (Backwards, forwards)) +import Data.Functor ((<&>)) +import Data.Functor.Identity import Data.Foldable (foldr, toList) import Data.Maybe (listToMaybe,isJust,fromMaybe) import qualified Data.List as L (deleteBy,find,splitAt,filter,nub) @@ -517,6 +520,24 @@ delete' w s = s { current = removeFromScreen (current s) where removeFromWorkspace ws = ws { stack = stack ws >>= filter (/=w) } removeFromScreen scr = scr { workspace = removeFromWorkspace (workspace scr) } +-- | Map over the 'Workspace's of a 'StackSet'. +mapWorkspaces + :: (Workspace i l a -> Workspace i' l' a) + -> StackSet i l a sid sd -> StackSet i' l' a sid sd +mapWorkspaces f = runIdentity . traverseWorkspaces (Identity . f) + +-- | 'traverse' the 'Workspace's of a 'StackSet'. +traverseWorkspaces + :: Applicative f + => (Workspace i l a -> f (Workspace i' l' a)) + -> StackSet i l a sid sd -> f (StackSet i' l' a sid sd) +traverseWorkspaces f s = StackSet + <$> onScreen (current s) + <*> traverse onScreen (visible s) + <*> traverse f (hidden s) + <*> pure (floating s) + where onScreen scr = f (workspace scr) <&> \w -> scr{ workspace = w } + ------------------------------------------------------------------------ -- | Given a window, and its preferred rectangle, set it as floating