Allow messages to flow to original modifier in conditional layout

XMonad/Layout/ConditionalLayout.hs

@@ -1,9 +1,9 @@
+{-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TupleSections #-}
 
 -----------------------------------------------------------------------------
@@ -16,7 +16,7 @@
 -- Stability    : unstable
 -- Portability  : portable
 --
--- This module provides a LayoutModifier that modifies an existing
+-- This module provides a LayoutModifier combinator that modifies an existing
 -- ModifiedLayout so that its modifications are only applied when a particular
 -- condition is met.
 -----------------------------------------------------------------------------
@@ -25,10 +25,22 @@ module XMonad.Layout.ConditionalLayout where
 
 import XMonad
 import XMonad.Layout.LayoutModifier
-
+import qualified XMonad.StackSet as W
+
+-- | A 'ModifierCondition' is a condition run in 'X' that takes a 'WorkspaceId'
+-- as a parameter. The reason that this must exist as a type class and a simple
+-- function will not suffice is that 'ModifierCondition's are used as parameters
+-- to 'ConditionalLayoutModifier', which must implement 'Read' and 'Show' in
+-- order to also implement 'LayoutModifier'. By defining a new type for
+-- condition, we sidestep the issue that functions can not implement these
+-- typeclasses.
 class (Read c, Show c) => ModifierCondition c where
-  shouldApply :: c -> X Bool
+  shouldApply :: c -> WorkspaceId -> X Bool
 
+-- | 'ConditionalLayoutModifier' takes a condition implemented as a
+-- 'ModifierCondition' together with a 'LayoutModifier' and builds a new
+-- 'LayoutModifier' that is exactly like the provided 'LayoutModifier', except
+-- that it is only applied when the provided condition evalutes to True.
 data ConditionalLayoutModifier m c a = (Read (m a), Show (m a), ModifierCondition c) =>
   ConditionalLayoutModifier c (m a)
 
@@ -37,28 +49,21 @@ deriving instance (Read (m a), Show (m a), ModifierCondition c) =>
 deriving instance (Read (m a), Show (m a), ModifierCondition c) =>
          Read (ConditionalLayoutModifier m c a)
 
-data NoOpModifier a = NoOpModifier deriving (Read,Show)
+data NoOpModifier a = NoOpModifier deriving (Read, Show)
 
 instance LayoutModifier NoOpModifier a
 
-runModifierIfCondition ::
-  (ModifierCondition c, LayoutModifier m a) =>
-  m a -> c -> (forall m1. LayoutModifier m1 a => m1 a -> X b) -> X b
-runModifierIfCondition modifier condition action = do
-  applyModifier <- shouldApply condition
-  if applyModifier
-    then action modifier
-    else action NoOpModifier
-
 instance (ModifierCondition c, LayoutModifier m Window) =>
   LayoutModifier (ConditionalLayoutModifier m c) Window where
 
-  modifyLayout (ConditionalLayoutModifier condition originalModifier) w r =
-    runModifierIfCondition originalModifier condition
-                             (\modifier -> modifyLayout modifier w r)
+  modifyLayout (ConditionalLayoutModifier condition originalModifier) w r = do
+    applyModifier <- shouldApply condition $ W.tag w
+    if applyModifier
+      then modifyLayout originalModifier w r
+      else modifyLayout NoOpModifier w r
 
   modifyLayoutWithUpdate (ConditionalLayoutModifier condition originalModifier) w r = do
-    applyModifier <- shouldApply condition
+    applyModifier <- shouldApply condition $ W.tag w
     if applyModifier
       then do
         (res, updatedModifier) <- modifyLayoutWithUpdate originalModifier w r
@@ -67,25 +72,23 @@ instance (ModifierCondition c, LayoutModifier m Window) =>
         return (res, updatedModifiedModifier)
       else (, Nothing) . fst <$> modifyLayoutWithUpdate NoOpModifier w r
 
-  -- This function is not allowed to have any downstream effect, so it seems
-  -- more reasonable to simply allow the message to pass than to make it depend
-  -- on the condition.
-  handleMess (ConditionalLayoutModifier condition originalModifier) mess = do
-    fmap (ConditionalLayoutModifier condition) <$> handleMess originalModifier mess
-
-  handleMessOrMaybeModifyIt (ConditionalLayoutModifier condition originalModifier) mess = do
-    applyModifier <- shouldApply condition
-    if applyModifier
-       then do
-         result <- handleMessOrMaybeModifyIt originalModifier mess
-         return $ case result of
-           Nothing -> Nothing
-           Just (Left updated) -> Just $ Left $ ConditionalLayoutModifier condition updated
-           Just (Right message) -> Just $ Right message
-       else return Nothing
-
-  redoLayout (ConditionalLayoutModifier condition originalModifier) r ms wrs = do
-    applyModifier <- shouldApply condition
+  -- This function is not allowed to have any effect on layout, so we always
+  -- pass the message along to the original modifier to ensure that it is
+  -- allowed to update its internal state appropriately. This is particularly
+  -- important for messages like 'Hide' or 'ReleaseResources'.
+  handleMessOrMaybeModifyIt
+    (ConditionalLayoutModifier condition originalModifier) mess = do
+      result <- handleMessOrMaybeModifyIt originalModifier mess
+      return $ case result of
+                 Nothing -> Nothing
+                 Just (Left updated) ->
+                   Just $ Left $
+                        ConditionalLayoutModifier condition updated
+                 Just (Right message) -> Just $ Right message
+
+  redoLayoutWithWorkspace (ConditionalLayoutModifier condition originalModifier)
+                       w r ms wrs = do
+    applyModifier <- shouldApply condition $ W.tag w
     if applyModifier
       then do
         (res, updatedModifier) <- redoLayout originalModifier r ms wrs

XMonad/Layout/LayoutModifier.hs

@@ -188,11 +188,27 @@ class (Show (m a), Read (m a)) => LayoutModifier m a where
     redoLayout :: m a               -- ^ the layout modifier
                -> Rectangle         -- ^ screen rectangle
                -> Maybe (Stack a)   -- ^ current window stack
-               -> [(a, Rectangle)]  -- ^ (window,rectangle) pairs returned
+               -> [(a, Rectangle)]  -- ^ (window, rectangle) pairs returned
                                     -- by the underlying layout
                -> X ([(a, Rectangle)], Maybe (m a))
     redoLayout m r ms wrs = do hook m; return $ pureModifier m r ms wrs
 
+    -- | 'redoLayoutWithWorkspace' is exactly like 'redoLayout', execept
+    -- that the original workspace is also provided as an argument
+    redoLayoutWithWorkspace :: m a
+                            -- ^ the layout modifier
+                            -> Workspace WorkspaceId (ModifiedLayout m l a) a
+                            -- ^ The original workspace that is being laid out
+                            -> Rectangle
+                            -- ^ screen rectangle
+                            -> Maybe (Stack a)
+                            -- ^ current window stack
+                            -> [(a, Rectangle)]
+                            -- ^ (window, rectangle) pairs returned by the
+                            -- underlying layout
+                            -> X ([(a, Rectangle)], Maybe (m a))
+    redoLayoutWithWorkspace m _ = redoLayout m
+
     -- | 'pureModifier' allows you to intercept a call to 'runLayout'
     --   /after/ it is called on the underlying layout, in order to
     --   modify the list of window\/rectangle pairings it has returned,
@@ -251,9 +267,9 @@ class (Show (m a), Read (m a)) => LayoutModifier m a where
 -- | The 'LayoutClass' instance for a 'ModifiedLayout' defines the
 --   semantics of a 'LayoutModifier' applied to an underlying layout.
 instance (LayoutModifier m a, LayoutClass l a, Typeable m) => LayoutClass (ModifiedLayout m l) a where
-    runLayout (Workspace i (ModifiedLayout m l) ms) r =
+    runLayout w@(Workspace i (ModifiedLayout m l) ms) r =
         do ((ws, ml'),mm')  <- modifyLayoutWithUpdate m (Workspace i l ms) r
-           (ws', mm'') <- redoLayout (fromMaybe m mm') r ms ws
+           (ws', mm'') <- redoLayoutWithWorkspace (fromMaybe m mm') w r ms ws
            let ml'' = case mm'' `mplus` mm' of
                         Just m' -> Just $ ModifiedLayout m' $ fromMaybe l ml'
                         Nothing -> ModifiedLayout m <$> ml'