From 1011465e1003b7c9a780e02ae55cb11a5ee47139 Mon Sep 17 00:00:00 2001 From: Ivan Malison Date: Wed, 4 Aug 2021 20:40:36 -0600 Subject: [PATCH 1/3] X.L.ConditionalLayoutModifier: Init --- CHANGES.md | 6 ++ XMonad/Layout/ConditionalModifier.hs | 100 +++++++++++++++++++++++++++ xmonad-contrib.cabal | 1 + 3 files changed, 107 insertions(+) create mode 100644 XMonad/Layout/ConditionalModifier.hs diff --git a/CHANGES.md b/CHANGES.md index 7da89b5411..e08eebbca9 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -134,6 +134,12 @@ Layout modifier for user provided per-window aspect ratios. + * `XMonad.Layout.ConditionModifier` + + This module provides a LayoutModifier that modifies an existing + LayoutModifier so that its modifications are only applied when a particular + condition is met. + * `XMonad.Hooks.TaffybarPagerHints` Add a module that exports information about XMonads internal state that is diff --git a/XMonad/Layout/ConditionalModifier.hs b/XMonad/Layout/ConditionalModifier.hs new file mode 100644 index 0000000000..e7187b893e --- /dev/null +++ b/XMonad/Layout/ConditionalModifier.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.ConditionModifier +-- Copyright : (c) Ivan Malison +-- License : BSD +-- +-- Maintainer : none +-- Stability : unstable +-- Portability : portable +-- +-- This module provides a LayoutModifier that modifies an existing +-- ModifiedLayout so that its modifications are only applied when a particular +-- condition is met. +----------------------------------------------------------------------------- + +module XMonad.Layout.ConditionalModifier where + +import XMonad +import XMonad.Layout.LayoutModifier + +class (Read c, Show c) => ModifierCondition c where + shouldApply :: c -> X Bool + +data ConditionalLayoutModifier m c a = (Read (m a), Show (m a), ModifierCondition c) => + ConditionalLayoutModifier c (m a) + +deriving instance (Read (m a), Show (m a), ModifierCondition c) => + Show (ConditionalLayoutModifier m c a) +deriving instance (Read (m a), Show (m a), ModifierCondition c) => + Read (ConditionalLayoutModifier m c a) + +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) + + modifyLayoutWithUpdate (ConditionalLayoutModifier condition originalModifier) w r = do + applyModifier <- shouldApply condition + if applyModifier + then do + (res, updatedModifier) <- modifyLayoutWithUpdate originalModifier w r + let updatedModifiedModifier = + ConditionalLayoutModifier condition <$> updatedModifier + 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 + if applyModifier + then do + (res, updatedModifier) <- redoLayout originalModifier r ms wrs + let updatedModifiedModifier = + ConditionalLayoutModifier condition <$> updatedModifier + return (res, updatedModifiedModifier) + else (, Nothing) . fst <$> redoLayout NoOpModifier r ms wrs + + modifyDescription (ConditionalLayoutModifier _ originalModifier) l = + modifyDescription originalModifier l + + diff --git a/xmonad-contrib.cabal b/xmonad-contrib.cabal index 3946c684d7..ef304379b6 100644 --- a/xmonad-contrib.cabal +++ b/xmonad-contrib.cabal @@ -213,6 +213,7 @@ library XMonad.Layout.Column XMonad.Layout.Combo XMonad.Layout.ComboP + XMonad.Layout.ConditionalModifier XMonad.Layout.Cross XMonad.Layout.Decoration XMonad.Layout.DecorationAddons From 726cc6d1cdbb94e91407f0017b2ecd1d1ad8029e Mon Sep 17 00:00:00 2001 From: Ivan Malison Date: Sat, 7 Aug 2021 17:03:41 -0600 Subject: [PATCH 2/3] ConditionalModifier -> ConditionalLayout --- .../Layout/{ConditionalModifier.hs => ConditionalLayout.hs} | 4 ++-- xmonad-contrib.cabal | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) rename XMonad/Layout/{ConditionalModifier.hs => ConditionalLayout.hs} (97%) diff --git a/XMonad/Layout/ConditionalModifier.hs b/XMonad/Layout/ConditionalLayout.hs similarity index 97% rename from XMonad/Layout/ConditionalModifier.hs rename to XMonad/Layout/ConditionalLayout.hs index e7187b893e..3905a18618 100644 --- a/XMonad/Layout/ConditionalModifier.hs +++ b/XMonad/Layout/ConditionalLayout.hs @@ -8,7 +8,7 @@ ----------------------------------------------------------------------------- -- | --- Module : XMonad.Layout.ConditionModifier +-- Module : XMonad.Layout.ConditionalLayout -- Copyright : (c) Ivan Malison -- License : BSD -- @@ -21,7 +21,7 @@ -- condition is met. ----------------------------------------------------------------------------- -module XMonad.Layout.ConditionalModifier where +module XMonad.Layout.ConditionalLayout where import XMonad import XMonad.Layout.LayoutModifier diff --git a/xmonad-contrib.cabal b/xmonad-contrib.cabal index ef304379b6..4aa45c1b59 100644 --- a/xmonad-contrib.cabal +++ b/xmonad-contrib.cabal @@ -213,7 +213,7 @@ library XMonad.Layout.Column XMonad.Layout.Combo XMonad.Layout.ComboP - XMonad.Layout.ConditionalModifier + XMonad.Layout.ConditionalLayout XMonad.Layout.Cross XMonad.Layout.Decoration XMonad.Layout.DecorationAddons From cca433e9f5753a3c4e1b8550cef320fd6dba6233 Mon Sep 17 00:00:00 2001 From: Ivan Malison Date: Wed, 11 Aug 2021 21:38:29 -0600 Subject: [PATCH 3/3] Allow messages to flow to original modifier in conditional layout --- XMonad/Layout/ConditionalLayout.hs | 81 ++++++++++++++++-------------- XMonad/Layout/LayoutModifier.hs | 22 ++++++-- 2 files changed, 61 insertions(+), 42 deletions(-) diff --git a/XMonad/Layout/ConditionalLayout.hs b/XMonad/Layout/ConditionalLayout.hs index 3905a18618..f40815befb 100644 --- a/XMonad/Layout/ConditionalLayout.hs +++ b/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 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'