Relocate the log hook

CHANGES.md

@@ -4,10 +4,35 @@
 
 ### 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.
+
+    * The log hook now runs *before* the layout and other refresh IO.
+
 * 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`.
+
+    * The log hook may now make changes to the windowset and have those changes
+      handled seamlessly by the accompanying refresh, at no risk of infinite
+      recursion.
+
 * Exported `sendRestart` and `sendReplace` from `XMonad.Operations`.
 
 * Exported `buildLaunch` from `XMonad.Main`.

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
@@ -47,10 +48,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
@@ -107,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
@@ -157,16 +158,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 +188,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
 

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)