From 0a993489eb7c838805d550df8790daf637a33b93 Mon Sep 17 00:00:00 2001 From: Ivan Malison Date: Wed, 11 Aug 2021 21:38:29 -0600 Subject: [PATCH] Allow messages to flow to original modifier in conditional layout --- XMonad/Layout/ConditionalLayout.hs | 74 +++++++++++++++--------------- XMonad/Layout/LayoutModifier.hs | 22 +++++++-- 2 files changed, 55 insertions(+), 41 deletions(-) diff --git a/XMonad/Layout/ConditionalLayout.hs b/XMonad/Layout/ConditionalLayout.hs index 3905a18618..dc61fe9342 100644 --- a/XMonad/Layout/ConditionalLayout.hs +++ b/XMonad/Layout/ConditionalLayout.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- @@ -16,7 +17,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 +26,16 @@ module XMonad.Layout.ConditionalLayout where import XMonad import XMonad.Layout.LayoutModifier +import qualified XMonad.StackSet as W +-- | A 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 +44,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 +67,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 diff --git a/XMonad/Layout/LayoutModifier.hs b/XMonad/Layout/LayoutModifier.hs index f2e7cf603c..0ad39cae2b 100644 --- a/XMonad/Layout/LayoutModifier.hs +++ b/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'