Purify the unclean

CHANGES.md

@@ -4,10 +4,43 @@
 
 ### Breaking Changes
 
+* Deprecated `runOnWorkspaces`.
+
+* 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.
+
+    * 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
 
+* X.StackSet now provides `mapWorkspaces` and `traverseWorkspaces`.
+
+* MVDT:
+
+    * X actions can now be combined without performing spurious refreshes.
+
+    * 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`.

src/XMonad/Core.hs

@@ -2,12 +2,14 @@
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE BlockArguments #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -39,6 +41,7 @@ module XMonad.Core (
     ManageHook, Query(..), runQuery, Directories'(..), Directories, getDirectories,
   ) where
 
+import XMonad.Internal.Core (Internal)
 import XMonad.StackSet hiding (modify)
 
 import Prelude
@@ -47,11 +50,11 @@ 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.Foldable (for_)
 import Data.Time.Clock (UTCTime)
 import Data.Default.Class
 import System.Environment (lookupEnv)
@@ -107,6 +110,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
@@ -157,16 +161,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,19 +191,20 @@ 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.
 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
 
@@ -214,11 +222,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.
@@ -228,7 +236,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
@@ -466,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.
-runOnWorkspaces :: (WindowSpace -> X WindowSpace) -> X ()
-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 } }
+{-# DEPRECATED runOnWorkspaces "Use `traverseWorkspaces`." #-}
+runOnWorkspaces :: MonadState XState m => (WindowSpace -> m WindowSpace) -> m ()
+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:
@@ -750,11 +756,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

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
+

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)

src/XMonad/Main.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE BlockArguments #-}
 
 ----------------------------------------------------------------------------
 -- |
@@ -33,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)
@@ -191,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
@@ -203,6 +207,7 @@ launch initxmc drs = do
             , mousePosition = Nothing
             , currentEvent  = Nothing
             , directories   = drs
+            , internal      = int
             }
 
         st = XState
@@ -234,18 +239,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 +277,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)
 

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 <&&>, <||>