Merge pull request #605 from TheMC47/pp-predicates

`ppPrinters` for custom workspace types, `copiesPP` fix

CHANGES.md

@@ -179,8 +179,13 @@
       `xmobarFont` for selecting an alternative font.
 
     - Added `ppRename` to `PP`, which makes it possible for extensions like
-      `workspaceNamesPP`, `marshallPP` and/or `clickablePP` to compose
-      intuitively.
+      `workspaceNamesPP`, `marshallPP` and/or `clickablePP` (which need to
+      access the original `WorkspaceId`) to compose intuitively.
+
+    - Added `ppPrinters`, `WSPP` and `fallbackPrinters` as a generalization of
+      the `ppCurrent`, `ppVisible`… sextet, which makes it possible for
+      extensions like `copiesPP` (which acts as if there was a
+      `ppHiddenWithCopies`) to compose intuitively.
 
   * `XMonad.Hooks.StatusBar`
 

XMonad/Actions/CopyWindow.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE RecordWildCards #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonad.Actions.CopyWindow
@@ -26,11 +27,12 @@ module XMonad.Actions.CopyWindow (
                                 ) where
 
 import XMonad
+import XMonad.Prelude
 import Control.Arrow ((&&&))
 import qualified Data.List as L
 
 import XMonad.Actions.WindowGo
-import XMonad.Hooks.StatusBar.PP (PP(..))
+import XMonad.Hooks.StatusBar.PP (PP(..), WS(..), isHidden)
 import qualified XMonad.StackSet as W
 
 -- $usage
@@ -93,9 +95,9 @@ import qualified XMonad.StackSet as W
 copiesPP :: (WorkspaceId -> String) -> PP -> X PP
 copiesPP wtoS pp = do
     copies <- wsContainingCopies
-    let check ws | ws `elem` copies = wtoS ws
-                 | otherwise = ppHidden pp ws
-    return pp { ppHidden = check }
+    let check WS{..} = W.tag wsWS `elem` copies
+    let printer = (asks (isHidden <&&> check) >>= guard) $> wtoS
+    return pp{ ppPrinters = printer <|> ppPrinters pp }
 
 -- | Copy the focused window to a workspace.
 copy :: (Eq s, Eq i, Eq a) => i -> W.StackSet i l a s sd -> W.StackSet i l a s sd

XMonad/Hooks/StatusBar/PP.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE PatternGuards       #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE FlexibleContexts    #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonad.Hooks.StatusBar.PP
@@ -32,6 +34,11 @@ module XMonad.Hooks.StatusBar.PP (
     dynamicLogString,
     dynamicLogWithPP,
 
+    -- * Predicates and formatters
+    -- $predicates
+    WS(..), WSPP, WSPP', fallbackPrinters,
+    isUrgent, isCurrent, isVisible, isVisibleNoWindows, isHidden,
+
     -- * Example formatters
     dzenPP, xmobarPP, sjanssenPP, byorgeyPP,
 
@@ -47,10 +54,11 @@ module XMonad.Hooks.StatusBar.PP (
 
     ) where
 
-import qualified XMonad.StackSet as S
+import Control.Monad.Reader
 
 import XMonad
 import XMonad.Prelude
+import qualified XMonad.StackSet as S
 
 import XMonad.Util.NamedWindows
 import XMonad.Util.WorkspaceCompare
@@ -132,6 +140,9 @@ data PP = PP { ppCurrent :: WorkspaceId -> String
                -- formatting. Note that this is only used by
                -- 'dynamicLogWithPP'; it won't work with 'dynamicLogString' or
                -- "XMonad.Hooks.StatusBar".
+             , ppPrinters :: WSPP
+               -- ^ extend workspace types with custom predicates.
+               -- Check $predicates for more details.
              }
 
 -- | The default pretty printing options:
@@ -157,6 +168,7 @@ instance Default PP where
            , ppOutput           = putStrLn
            , ppSort             = getSortByIndex
            , ppExtras           = []
+           , ppPrinters         = empty
            }
 
 -- | Format the current status using the supplied pretty-printing format,
@@ -201,17 +213,112 @@ pprWindowSet :: WorkspaceSort -> [Window] -> PP -> WindowSet -> String
 pprWindowSet sort' urgents pp s = sepBy (ppWsSep pp) . map fmt . sort' $
             map S.workspace (S.current s : S.visible s) ++ S.hidden s
   where
-    this     = S.currentTag s
-    visibles = map (S.tag . S.workspace) (S.visible s)
-
-    fmt w = printer pp (ppRename pp (S.tag w) w)
+    fmt :: WindowSpace -> String
+    fmt w = pr (ppRename pp (S.tag w) w)
       where
-        printer | any (\x -> (== Just (S.tag w)) (S.findTag x s)) urgents = ppUrgent
-                | S.tag w == this                                         = ppCurrent
-                | S.tag w `elem` visibles && isJust (S.stack w)           = ppVisible
-                | S.tag w `elem` visibles                                 = liftA2 fromMaybe ppVisible ppVisibleNoWindows
-                | isJust (S.stack w)                                      = ppHidden
-                | otherwise                                               = ppHiddenNoWindows
+        printers = ppPrinters pp <|> fallbackPrinters
+        pr = fromMaybe id $ runReaderT printers $
+            WS{ wsUrgents = urgents, wsWindowSet = s, wsWS = w, wsPP = pp }
+
+-- $predicates
+-- Using 'WSPP' with 'ppPrinters' allows extension modules (and users) to
+-- extend 'PP' with new workspace types beyond 'ppCurrent', 'ppUrgent', and
+-- the rest.
+
+-- | The data available to 'WSPP''.
+data WS = WS{ wsUrgents :: [Window] -- ^ Urgent windows
+            , wsWindowSet :: WindowSet -- ^ The entire 'WindowSet', for context
+            , wsWS :: WindowSpace -- ^ The 'WindowSpace' being formatted
+            , wsPP :: PP -- ^ The actual final 'PP'
+            }
+
+-- XXX: ReaderT instead of -> because there is no
+--
+-- > instance Alternative (Λa. r -> Maybe a)
+--
+-- (there cannot be, Haskell has no Λ), and there is no
+--
+-- > instance Alternative (Compose ((->) r) Maybe)
+--
+-- either, and even if there was, Compose isn't very practical.
+--
+-- But we don't need Alternative for WS -> Bool, so we use the simple
+-- function-based reader for the condition functions, as their definitions are
+-- much prettier that way. This may be a bit confusing. :-/
+type WSPP' = ReaderT WS Maybe
+
+-- | The type allowing to build formatters (and predicates). See
+-- the source 'fallbackPrinters' for an example.
+type WSPP = WSPP' (WorkspaceId -> String)
+
+-- | For a 'PP' @pp@, @fallbackPrinters pp@ returns the default 'WSPP'
+-- used to format workspaces: the formatter chosen corresponds to the
+-- first matching workspace type, respecting the following precedence:
+-- 'ppUrgent', 'ppCurrent', 'ppVisible', 'ppVisibleNoWindows', 'ppHidden',
+-- 'ppHiddenNoWindows'.
+--
+-- This can be useful if one needs to use the default set of formatters and
+-- post-process their output. (For pre-processing their input, there's
+-- 'ppRename'.)
+fallbackPrinters :: WSPP
+fallbackPrinters = isUrgent            ?-> ppUrgent
+               <|> isCurrent'          ?-> ppCurrent
+               <|> isVisible'          ?-> ppVisible
+               <|> isVisibleNoWindows' ?-> liftA2 fromMaybe ppVisible ppVisibleNoWindows
+               <|> isHidden'           ?-> ppHidden
+               <|> pure True           ?-> ppHiddenNoWindows
+  where
+    cond ?-> ppr = (asks cond >>= guard) *> asks (ppr . wsPP)
+
+-- | Predicate for urgent workspaces.
+isUrgent :: WS -> Bool
+isUrgent WS{..} = any (\x -> (== Just (S.tag wsWS)) (S.findTag x wsWindowSet)) wsUrgents
+
+-- | Predicate for the current workspace. Caution: assumes default
+-- precedence is respected.
+isCurrent' :: WS -> Bool
+isCurrent' WS{..} = S.tag wsWS == S.currentTag wsWindowSet
+
+-- | Predicate for the current workspace.
+isCurrent :: WS -> Bool
+isCurrent = (not <$> isUrgent) <&&> isCurrent'
+
+-- | Predicate for visible workspaces. Caution: assumes default
+-- precedence is respected.
+isVisible' :: WS -> Bool
+isVisible' = isVisibleNoWindows' <&&> isJust . S.stack . wsWS
+
+-- | Predicate for visible workspaces.
+isVisible :: WS -> Bool
+isVisible = (not <$> isUrgent) <&&> (not <$> isCurrent') <&&> isVisible'
+
+-- | Predicate for visible workspaces that have no windows. Caution:
+-- assumes default precedence is respected.
+isVisibleNoWindows' :: WS -> Bool
+isVisibleNoWindows' WS{..} = S.tag wsWS `elem` visibles
+  where visibles = map (S.tag . S.workspace) (S.visible wsWindowSet)
+
+-- | Predicate for visible workspaces that have no windows.
+isVisibleNoWindows :: WS -> Bool
+isVisibleNoWindows =
+    (not <$> isUrgent)
+        <&&> (not <$> isCurrent')
+        <&&> (not <$> isVisible')
+        <&&> isVisibleNoWindows'
+
+-- | Predicate for non-empty hidden workspaces. Caution: assumes default
+-- precedence is respected.
+isHidden' :: WS -> Bool
+isHidden' = isJust . S.stack . wsWS
+
+-- | Predicate for hidden workspaces.
+isHidden :: WS -> Bool
+isHidden =
+    (not <$> isUrgent)
+        <&&> (not <$> isCurrent')
+        <&&> (not <$> isVisible')
+        <&&> (not <$> isVisibleNoWindows')
+        <&&> isHidden'
 
 pprWindowSetXinerama :: WindowSet -> String
 pprWindowSetXinerama ws = "[" ++ unwords onscreen ++ "] " ++ unwords offscreen