Merge pull request #481 from liskin/pr/pp-composable-rename

Extend PP with ppRename: nicer compose of WorkspaceNames, ClickableWorkspaces, …

CHANGES.md

@@ -45,6 +45,11 @@
     - `execScriptHook` now has an `X` constraint (was: `MonadIO`), due to changes
       in how the xmonad core handles XDG directories.
 
+  * `XMonad.Actions.WorkspaceNames`
+
+    - The type of `getWorkspaceNames` was changed to fit into the new `ppRename`
+      field of `PP`.
+
 ### New Modules
 
   * `XMonad.Util.Hacks`
@@ -240,6 +245,10 @@
       to provide the configs for the already existing functionality. This provides
       multiple status bars support.
 
+    - Added `ppRename` to `PP`, which makes it possible for extensions like
+      `workspaceNamesPP`, `marshallPP` and/or `clickablePP` to compose
+      intuitively.
+
   * `XMonad.Layout.BoringWindows`
 
     - Added boring-aware `swapUp`, `swapDown`, `siftUp`, and `siftDown` functions.

XMonad/Actions/WorkspaceNames.hs

@@ -54,6 +54,7 @@ import XMonad.Prompt (mkXPrompt, XPConfig)
 import XMonad.Prompt.Workspace (Wor(Wor))
 import XMonad.Util.WorkspaceCompare (getSortByIndex)
 
+import Control.Monad ((>=>))
 import Data.Functor ((<&>))
 import qualified Data.Map as M
 import Data.Maybe (fromMaybe)
@@ -101,12 +102,12 @@ getWorkspaceNames' = do
     WorkspaceNames m <- XS.get
     return (`M.lookup` m)
 
--- | Returns a function that maps workspace tag @\"t\"@ to @\"t:name\"@ for
--- workspaces with a name, and to @\"t\"@ otherwise.
-getWorkspaceNames :: X (WorkspaceId -> String)
-getWorkspaceNames = do
-    lookup' <- getWorkspaceNames'
-    return $ \wks -> wks ++ maybe "" (':' :) (lookup' wks)
+-- | Returns a function for 'ppRename' that appends @sep@ and the workspace
+-- name, if set.
+getWorkspaceNames :: String -> X (String -> WindowSpace -> String)
+getWorkspaceNames sep = ren <$> getWorkspaceNames'
+  where
+    ren name s w = s ++ maybe "" (sep ++) (name (W.tag w))
 
 -- | Gets the name of a workspace, if set, otherwise returns nothing.
 getWorkspaceName :: WorkspaceId -> X (Maybe String)
@@ -139,17 +140,7 @@ renameWorkspace conf =
 -- | Modify "XMonad.Hooks.DynamicLog"\'s pretty-printing format to show
 -- workspace names as well.
 workspaceNamesPP :: PP -> X PP
-workspaceNamesPP pp = do
-    names <- getWorkspaceNames
-    return $
-        pp {
-            ppCurrent         = ppCurrent         pp . names,
-            ppVisible         = ppVisible         pp . names,
-            ppHidden          = ppHidden          pp . names,
-            ppHiddenNoWindows = ppHiddenNoWindows pp . names,
-            ppVisibleNoWindows= ppVisibleNoWindows pp <&> (. names),
-            ppUrgent          = ppUrgent          pp . names
-        }
+workspaceNamesPP pp = getWorkspaceNames ":" <&> \ren -> pp{ ppRename = ppRename pp >=> ren }
 
 -- | See 'XMonad.Actions.SwapWorkspaces.swapTo'. This is the same with names.
 swapTo :: Direction1D -> X ()
@@ -176,17 +167,15 @@ swapNames w1 w2 = do
     XS.put $ WorkspaceNames $ set w1 (getname w2) $ set w2 (getname w1) $ m
 
 -- | Same behavior than 'XMonad.Prompt.Workspace.workspacePrompt' excepted it acts on the workspace name provided by this module.
-workspaceNamePrompt :: XPConfig -> (String -> X ()) -> X ()
+workspaceNamePrompt :: XPConfig -> (WorkspaceId -> X ()) -> X ()
 workspaceNamePrompt conf job = do
-    myWorkspaces <- gets $ map W.tag . W.workspaces . windowset
-    myWorkspacesName <- getWorkspaceNames >>= \f -> return $ map f myWorkspaces
-    let pairs = zip myWorkspacesName myWorkspaces
+    myWorkspaces <- gets $ W.workspaces . windowset
+    myWorkspacesName <- getWorkspaceNames ":" <&> \n -> [n (W.tag w) w | w <- myWorkspaces]
+    let pairs = zip myWorkspacesName (map W.tag myWorkspaces)
     mkXPrompt (Wor "Select workspace: ") conf
               (contains myWorkspacesName)
               (job . toWsId pairs)
-  where toWsId pairs name = case lookup name pairs of
-                                Nothing -> ""
-                                Just i -> i
+  where toWsId pairs name = fromMaybe "" (lookup name pairs)
         contains completions input =
           return $ filter (Data.List.isInfixOf input) completions
 
@@ -197,6 +186,5 @@ workspaceNamePrompt conf job = do
 -- Usage:
 -- > logHook = (workspaceNamesListTransform >>= ewmhDesktopsLogHookCustom) <+> …
 workspaceNamesListTransform :: X ([WindowSpace] -> [WindowSpace])
-workspaceNamesListTransform = do
-    names <- getWorkspaceNames
-    return $ map $ \ws -> ws{ W.tag = names $ W.tag ws }
+workspaceNamesListTransform =
+    getWorkspaceNames ":" <&> \names -> map $ \ws -> ws{ W.tag = names (W.tag ws) ws }

XMonad/Hooks/DynamicLog.hs

@@ -583,11 +583,13 @@ dynamicLogString pp = do
 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
+  where
+    this     = S.currentTag s
     visibles = map (S.tag . S.workspace) (S.visible s)
 
-         fmt w = printer pp (S.tag w)
-          where printer | any (\x -> (== Just (S.tag w)) (S.findTag x s)) urgents  = ppUrgent
+    fmt w = printer pp (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
@@ -936,6 +938,9 @@ data PP = PP { ppCurrent :: WorkspaceId -> String
                -- ^ how to print tags of empty visible workspaces
              , ppUrgent :: WorkspaceId -> String
                -- ^ format to be applied to tags of urgent workspaces.
+             , ppRename :: String -> WindowSpace -> String
+               -- ^ rename/augment the workspace tag
+               --   (note that @WindowSpace -> …@ acts as a Reader monad)
              , ppSep :: String
                -- ^ separator to use between different log sections
                -- (window name, layout, workspaces)
@@ -987,6 +992,7 @@ instance Default PP where
                , ppHiddenNoWindows = const ""
                , ppVisibleNoWindows= Nothing
                , ppUrgent          = id
+               , ppRename          = pure
                , ppSep             = " : "
                , ppWsSep           = " "
                , ppTitle           = shorten 80

XMonad/Layout/IndependentScreens.hs

@@ -31,7 +31,6 @@ module XMonad.Layout.IndependentScreens (
 -- for the screen stuff
 import Control.Applicative(liftA2)
 import Control.Arrow hiding ((|||))
-import Data.Functor ((<&>))
 import Data.List (nub, genericLength)
 import Graphics.X11.Xinerama
 import XMonad
@@ -135,15 +134,8 @@ countScreens = fmap genericLength . liftIO $ openDisplay "" >>= liftA2 (<*) getS
 -- > logHook = let log screen handle = dynamicLogWithPP . marshallPP screen . pp $ handle
 -- >           in log 0 hLeft >> log 1 hRight
 marshallPP :: ScreenId -> PP -> PP
-marshallPP s pp = pp {
-    ppCurrent           = ppCurrent         pp . unmarshallW,
-    ppVisible           = ppVisible         pp . unmarshallW,
-    ppHidden            = ppHidden          pp . unmarshallW,
-    ppHiddenNoWindows   = ppHiddenNoWindows pp . unmarshallW,
-    ppVisibleNoWindows  = ppVisibleNoWindows pp <&> (. unmarshallW),
-    ppUrgent            = ppUrgent          pp . unmarshallW,
-    ppSort              = fmap (marshallSort s) (ppSort pp)
-    }
+marshallPP s pp = pp { ppRename = ppRename pp . unmarshallW
+                     , ppSort = fmap (marshallSort s) (ppSort pp) }
 
 -- | Take a pretty-printer and turn it into one that only runs when the current
 -- workspace is one associated with the given screen. The way this works is a

XMonad/Util/ClickableWorkspaces.hs

@@ -18,22 +18,16 @@ module XMonad.Util.ClickableWorkspaces (
   -- * Usage
   -- $usage
   clickablePP,
-  clickableRenamedPP,
   clickableWrap,
-
-  -- * Integrations
-  clickableWorkspaceNamesPP,
-  clickableMarshallPP,
-  clickableMarshallWorkspaceNamesPP
   ) where
 
+import Control.Monad ((>=>))
 import Data.Functor ((<&>))
 
 import XMonad
-import XMonad.Actions.WorkspaceNames
-import XMonad.Hooks.DynamicLog (xmobarAction, xmobarRaw, PP(..))
-import XMonad.Layout.IndependentScreens
+import XMonad.Hooks.DynamicLog (xmobarAction, PP(..))
 import XMonad.Util.WorkspaceCompare (getWsIndex)
+import qualified XMonad.StackSet as W
 
 -- $usage
 -- However you have set up your PP, apply @clickablePP@ to it, and bind the result
@@ -45,61 +39,26 @@ import XMonad.Util.WorkspaceCompare (getWsIndex)
 --   * @xdotool@ on system (in path)
 --   * "XMonad.Hooks.EwmhDesktops" for @xdotool@ support (see Hackage docs for setup)
 --   * use of UnsafeStdinReader/UnsafeXMonadLog in xmobarrc (rather than StdinReader/XMonadLog)
+--
+-- Note that UnsafeStdinReader is potentially dangerous if your workspace
+-- names are dynamically generated from untrusted input (like window titles).
+-- You may need to add @xmobarRaw@ to 'ppRename' before applying
+-- 'clickablePP' in such case.
 
 -- | Wrap string with an xmobar action that uses @xdotool@ to switch to
 -- workspace @i@.
 clickableWrap :: Int -> String -> String
-clickableWrap i ws = xmobarAction ("xdotool set_desktop " ++ show i) "1" $ xmobarRaw ws
+clickableWrap i ws = xmobarAction ("xdotool set_desktop " ++ show i) "1" ws
 
 -- | Return a function that wraps workspace names in an xmobar action that
--- switches to that workspace. That workspace name must be exactly as
--- configured in 'XMonad.Core.workspaces', so this takes an additional
--- parameter that allows renaming/marshalling of the name for display, which
--- is applied after the workspace's index is looked up.
+-- switches to that workspace.
 --
--- This additionally assumes that 'XMonad.Hooks.EwmhDesktops.ewmhDesktopsEventHook'
+-- This assumes that 'XMonad.Hooks.EwmhDesktops.ewmhDesktopsEventHook'
 -- isn't configured to change the workspace order. We might need to add an
 -- additional parameter if anyone needs that.
-getClickable :: (WorkspaceId -> String) -> X (WorkspaceId -> String)
-getClickable ren = do
-  wsIndex <- getWsIndex
-  return $ \ws -> case wsIndex ws of
-                    Just idx -> clickableWrap idx (ren ws)
-                    Nothing -> ws
+getClickable :: X (String -> WindowSpace -> String)
+getClickable = getWsIndex <&> \idx s w -> maybe id clickableWrap (idx (W.tag w)) s
 
--- | Apply clickable wrapping to all workspace fields in given PP.
+-- | Apply clickable wrapping to the given PP.
 clickablePP :: PP -> X PP
-clickablePP = clickableRenamedPP id
-
--- | Alternative to 'clickablePP' that allows changing the visible workspace
--- name. Useful for integration with modules that change workspace names, such
--- as "XMonad.Layout.IndependentScreens" and "XMonad.Actions.WorkspaceNames".
-clickableRenamedPP :: (WorkspaceId -> String) -> PP -> X PP
-clickableRenamedPP ren pp = do
-  clickable <- getClickable ren
-  return $
-    pp { ppCurrent         = ppCurrent pp . clickable
-       , ppVisible         = ppVisible pp . clickable
-       , ppHidden          = ppHidden pp . clickable
-       , ppHiddenNoWindows = ppHiddenNoWindows pp . clickable
-       , ppVisibleNoWindows= ppVisibleNoWindows pp <&> (. clickable)
-       , ppUrgent          = ppUrgent pp . clickable
-       }
-
--- | Integration with "XMonad.Actions.WorkspaceNames".
-clickableWorkspaceNamesPP :: PP -> X PP
-clickableWorkspaceNamesPP pp = do
-    rename <- getWorkspaceNames
-    clickableRenamedPP rename pp
-
--- | Integration with "XMonad.Layout.IndependentScreens".
-clickableMarshallPP :: ScreenId -> PP -> X PP
-clickableMarshallPP s pp =
-    clickableRenamedPP unmarshallW pp{ ppSort = marshallSort s <$> ppSort pp }
-
--- | Integration with both "XMonad.Actions.WorkspaceNames" and
--- "XMonad.Layout.IndependentScreens".
-clickableMarshallWorkspaceNamesPP :: ScreenId -> PP -> X PP
-clickableMarshallWorkspaceNamesPP s pp = do
-    rename <- getWorkspaceNames
-    clickableRenamedPP (unmarshallW . rename) pp{ ppSort = marshallSort s <$> ppSort pp }
+clickablePP pp = getClickable <&> \ren -> pp{ ppRename = ppRename pp >=> ren }