-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Actions.WorkspaceNames
-- Description :  Persistently rename workspace and swap them along with their names.
-- Copyright   :  (c) Tomas Janousek <tomi@nomi.cz>
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  Tomas Janousek <tomi@nomi.cz>
-- Stability   :  experimental
-- Portability :  unportable
--
-- Provides bindings to rename workspaces, show these names in a status bar and
-- swap workspaces along with their names. These names survive restart.
-- Together with "XMonad.Layout.WorkspaceDir" this provides for a fully
-- dynamic topic space workflow.
--
-----------------------------------------------------------------------------

module XMonad.Actions.WorkspaceNames (
    -- * Usage
    -- $usage

    -- * Workspace naming
    renameWorkspace,
    getWorkspaceNames',
    getWorkspaceNames,
    getWorkspaceName,
    getCurrentWorkspaceName,
    setWorkspaceName,
    setCurrentWorkspaceName,

    -- * Workspace swapping
    swapTo,
    swapTo',
    swapWithCurrent,

    -- * Workspace prompt
    workspaceNamePrompt,

    -- * StatusBar, EwmhDesktops integration
    workspaceNamesPP,
    workspaceNamesEwmh,
    ) where

import XMonad
import XMonad.Prelude (fromMaybe, isInfixOf, (<&>), (>=>))
import qualified XMonad.StackSet as W
import qualified XMonad.Util.ExtensibleState as XS

import XMonad.Actions.CycleWS (findWorkspace, WSType(..), Direction1D(..), anyWS)
import qualified XMonad.Actions.SwapWorkspaces as Swap
import XMonad.Hooks.StatusBar.PP (PP(..))
import XMonad.Hooks.EwmhDesktops (addEwmhWorkspaceRename)
import XMonad.Prompt (mkXPrompt, XPConfig, historyCompletionP)
import XMonad.Prompt.Workspace (Wor(Wor))
import XMonad.Util.WorkspaceCompare (getSortByIndex)

import qualified Data.Map as M

-- $usage
-- You can use this module with the following in your @xmonad.hs@ file:
--
-- > import XMonad.Actions.WorkspaceNames
--
-- Then add keybindings like the following:
--
-- >   , ((modm .|. shiftMask, xK_r      ), renameWorkspace def)
--
-- and apply workspaceNamesPP to your pretty-printer:
--
-- > myPP = workspaceNamesPP xmobarPP
--
-- Check "XMonad.Hooks.StatusBar" for more information on how to incorprate
-- this into your status bar.
--
-- To expose workspace names to pagers and other EWMH clients, integrate this
-- with "XMonad.Hooks.EwmhDesktops":
--
-- > main = xmonad $ … . workspaceNamesEwmh . ewmh . … $ def{…}
--
-- We also provide a modification of "XMonad.Actions.SwapWorkspaces"\'s
-- functionality, which may be used this way:
--
-- >   , ((modMask .|. shiftMask, xK_Left  ), swapTo Prev)
-- >   , ((modMask .|. shiftMask, xK_Right ), swapTo Next)
--
-- > [((modm .|. controlMask, k), swapWithCurrent i)
-- >     | (i, k) <- zip workspaces [xK_1 ..]]
--
-- For detailed instructions on editing your key bindings, see
-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.



-- | Workspace names container.
newtype WorkspaceNames = WorkspaceNames (M.Map WorkspaceId String)
    deriving (ReadPrec [WorkspaceNames]
ReadPrec WorkspaceNames
Int -> ReadS WorkspaceNames
ReadS [WorkspaceNames]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [WorkspaceNames]
$creadListPrec :: ReadPrec [WorkspaceNames]
readPrec :: ReadPrec WorkspaceNames
$creadPrec :: ReadPrec WorkspaceNames
readList :: ReadS [WorkspaceNames]
$creadList :: ReadS [WorkspaceNames]
readsPrec :: Int -> ReadS WorkspaceNames
$creadsPrec :: Int -> ReadS WorkspaceNames
Read, Int -> WorkspaceNames -> ShowS
[WorkspaceNames] -> ShowS
WorkspaceNames -> WorkspaceId
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
showList :: [WorkspaceNames] -> ShowS
$cshowList :: [WorkspaceNames] -> ShowS
show :: WorkspaceNames -> WorkspaceId
$cshow :: WorkspaceNames -> WorkspaceId
showsPrec :: Int -> WorkspaceNames -> ShowS
$cshowsPrec :: Int -> WorkspaceNames -> ShowS
Show)

instance ExtensionClass WorkspaceNames where
    initialValue :: WorkspaceNames
initialValue = Map WorkspaceId WorkspaceId -> WorkspaceNames
WorkspaceNames forall k a. Map k a
M.empty
    extensionType :: WorkspaceNames -> StateExtension
extensionType = forall a. (Read a, Show a, ExtensionClass a) => a -> StateExtension
PersistentExtension

-- | Returns a lookup function that maps workspace tags to workspace names.
getWorkspaceNames' :: X (WorkspaceId -> Maybe String)
getWorkspaceNames' :: X (WorkspaceId -> Maybe WorkspaceId)
getWorkspaceNames' = do
    WorkspaceNames Map WorkspaceId WorkspaceId
m <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map WorkspaceId WorkspaceId
m)

-- | Returns a function for 'ppRename' that appends @sep@ and the workspace
-- name, if set.
getWorkspaceNames :: String -> X (String -> WindowSpace -> String)
getWorkspaceNames :: WorkspaceId -> X (WorkspaceId -> WindowSpace -> WorkspaceId)
getWorkspaceNames WorkspaceId
sep = forall {t} {l} {a}.
(t -> Maybe WorkspaceId)
-> WorkspaceId -> Workspace t l a -> WorkspaceId
ren forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> X (WorkspaceId -> Maybe WorkspaceId)
getWorkspaceNames'
  where
    ren :: (t -> Maybe WorkspaceId)
-> WorkspaceId -> Workspace t l a -> WorkspaceId
ren t -> Maybe WorkspaceId
name WorkspaceId
s Workspace t l a
w = WorkspaceId
s forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe WorkspaceId
"" (WorkspaceId
sep forall a. [a] -> [a] -> [a]
++) (t -> Maybe WorkspaceId
name (forall i l a. Workspace i l a -> i
W.tag Workspace t l a
w))

-- | Gets the name of a workspace, if set, otherwise returns nothing.
getWorkspaceName :: WorkspaceId -> X (Maybe String)
getWorkspaceName :: WorkspaceId -> X (Maybe WorkspaceId)
getWorkspaceName WorkspaceId
w = (forall a b. (a -> b) -> a -> b
$ WorkspaceId
w) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> X (WorkspaceId -> Maybe WorkspaceId)
getWorkspaceNames'

-- | Gets the name of the current workspace. See 'getWorkspaceName'
getCurrentWorkspaceName :: X (Maybe String)
getCurrentWorkspaceName :: X (Maybe WorkspaceId)
getCurrentWorkspaceName = WorkspaceId -> X (Maybe WorkspaceId)
getWorkspaceName forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall i l a s sd. StackSet i l a s sd -> i
W.currentTag forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset)

-- | Sets the name of a workspace. Empty string makes the workspace unnamed
-- again.
setWorkspaceName :: WorkspaceId -> String -> X ()
setWorkspaceName :: WorkspaceId -> WorkspaceId -> X ()
setWorkspaceName WorkspaceId
w WorkspaceId
name = do
    WorkspaceNames Map WorkspaceId WorkspaceId
m <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
    forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put forall a b. (a -> b) -> a -> b
$ Map WorkspaceId WorkspaceId -> WorkspaceNames
WorkspaceNames forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null WorkspaceId
name then forall k a. Ord k => k -> Map k a -> Map k a
M.delete WorkspaceId
w Map WorkspaceId WorkspaceId
m else forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert WorkspaceId
w WorkspaceId
name Map WorkspaceId WorkspaceId
m
    X ()
refresh

-- | Sets the name of the current workspace. See 'setWorkspaceName'.
setCurrentWorkspaceName :: String -> X ()
setCurrentWorkspaceName :: WorkspaceId -> X ()
setCurrentWorkspaceName WorkspaceId
name = do
    WorkspaceId
current <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall i l a s sd. StackSet i l a s sd -> i
W.currentTag forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset)
    WorkspaceId -> WorkspaceId -> X ()
setWorkspaceName WorkspaceId
current WorkspaceId
name

-- | Prompt for a new name for the current workspace and set it.
renameWorkspace :: XPConfig -> X ()
renameWorkspace :: XPConfig -> X ()
renameWorkspace XPConfig
conf = do
    ComplFunction
completion <- (WorkspaceId -> Bool) -> X ComplFunction
historyCompletionP (WorkspaceId
prompt forall a. Eq a => a -> a -> Bool
==)
    forall p.
XPrompt p =>
p -> XPConfig -> ComplFunction -> (WorkspaceId -> X ()) -> X ()
mkXPrompt (WorkspaceId -> Wor
Wor WorkspaceId
prompt) XPConfig
conf ComplFunction
completion WorkspaceId -> X ()
setCurrentWorkspaceName
  where
    prompt :: WorkspaceId
prompt = WorkspaceId
"Workspace name: "

-- | See 'XMonad.Actions.SwapWorkspaces.swapTo'. This is the same with names.
swapTo :: Direction1D -> X ()
swapTo :: Direction1D -> X ()
swapTo Direction1D
dir = Direction1D -> WSType -> X ()
swapTo' Direction1D
dir WSType
anyWS

-- | Swap with the previous or next workspace of the given type.
swapTo' :: Direction1D -> WSType -> X ()
swapTo' :: Direction1D -> WSType -> X ()
swapTo' Direction1D
dir WSType
which = X WorkspaceSort -> Direction1D -> WSType -> Int -> X WorkspaceId
findWorkspace X WorkspaceSort
getSortByIndex Direction1D
dir WSType
which Int
1 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WorkspaceId -> X ()
swapWithCurrent

-- | See 'XMonad.Actions.SwapWorkspaces.swapWithCurrent'. This is almost the
-- same with names.
swapWithCurrent :: WorkspaceId -> X ()
swapWithCurrent :: WorkspaceId -> X ()
swapWithCurrent WorkspaceId
t = do
    WorkspaceId
current <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall i l a s sd. StackSet i l a s sd -> i
W.currentTag forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset)
    WorkspaceId -> WorkspaceId -> X ()
swapNames WorkspaceId
t WorkspaceId
current
    (WindowSet -> WindowSet) -> X ()
windows forall a b. (a -> b) -> a -> b
$ forall i l a s sd.
Eq i =>
i -> i -> StackSet i l a s sd -> StackSet i l a s sd
Swap.swapWorkspaces WorkspaceId
t WorkspaceId
current

-- | Swap names of the two workspaces.
swapNames :: WorkspaceId -> WorkspaceId -> X ()
swapNames :: WorkspaceId -> WorkspaceId -> X ()
swapNames WorkspaceId
w1 WorkspaceId
w2 = do
    WorkspaceNames Map WorkspaceId WorkspaceId
m <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
    let getname :: ShowS
getname WorkspaceId
w = forall a. a -> Maybe a -> a
fromMaybe WorkspaceId
"" forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup WorkspaceId
w Map WorkspaceId WorkspaceId
m
        set :: k -> t a -> Map k (t a) -> Map k (t a)
set k
w t a
name Map k (t a)
m' = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
name then forall k a. Ord k => k -> Map k a -> Map k a
M.delete k
w Map k (t a)
m' else forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
w t a
name Map k (t a)
m'
    forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put forall a b. (a -> b) -> a -> b
$ Map WorkspaceId WorkspaceId -> WorkspaceNames
WorkspaceNames forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *} {k} {a}.
(Foldable t, Ord k) =>
k -> t a -> Map k (t a) -> Map k (t a)
set WorkspaceId
w1 (ShowS
getname WorkspaceId
w2) forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *} {k} {a}.
(Foldable t, Ord k) =>
k -> t a -> Map k (t a) -> Map k (t a)
set WorkspaceId
w2 (ShowS
getname WorkspaceId
w1) Map WorkspaceId WorkspaceId
m

-- | Same behavior than 'XMonad.Prompt.Workspace.workspacePrompt' excepted it acts on the workspace name provided by this module.
workspaceNamePrompt :: XPConfig -> (WorkspaceId -> X ()) -> X ()
workspaceNamePrompt :: XPConfig -> (WorkspaceId -> X ()) -> X ()
workspaceNamePrompt XPConfig
conf WorkspaceId -> X ()
job = do
    [WindowSpace]
myWorkspaces <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall i l a s sd. StackSet i l a s sd -> [Workspace i l a]
W.workspaces forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset
    [WorkspaceId]
myWorkspacesName <- WorkspaceId -> X (WorkspaceId -> WindowSpace -> WorkspaceId)
getWorkspaceNames WorkspaceId
":" forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \WorkspaceId -> WindowSpace -> WorkspaceId
n -> [WorkspaceId -> WindowSpace -> WorkspaceId
n (forall i l a. Workspace i l a -> i
W.tag WindowSpace
w) WindowSpace
w | WindowSpace
w <- [WindowSpace]
myWorkspaces]
    let pairs :: [(WorkspaceId, WorkspaceId)]
pairs = forall a b. [a] -> [b] -> [(a, b)]
zip [WorkspaceId]
myWorkspacesName (forall a b. (a -> b) -> [a] -> [b]
map forall i l a. Workspace i l a -> i
W.tag [WindowSpace]
myWorkspaces)
    forall p.
XPrompt p =>
p -> XPConfig -> ComplFunction -> (WorkspaceId -> X ()) -> X ()
mkXPrompt (WorkspaceId -> Wor
Wor WorkspaceId
"Select workspace: ") XPConfig
conf
              (forall {m :: * -> *} {a}.
(Monad m, Eq a) =>
[[a]] -> [a] -> m [[a]]
contains [WorkspaceId]
myWorkspacesName)
              (WorkspaceId -> X ()
job forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Eq a => [(a, WorkspaceId)] -> a -> WorkspaceId
toWsId [(WorkspaceId, WorkspaceId)]
pairs)
  where toWsId :: [(a, WorkspaceId)] -> a -> WorkspaceId
toWsId [(a, WorkspaceId)]
pairs a
name = forall a. a -> Maybe a -> a
fromMaybe WorkspaceId
"" (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
name [(a, WorkspaceId)]
pairs)
        contains :: [[a]] -> [a] -> m [[a]]
contains [[a]]
completions [a]
input =
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => [a] -> [a] -> Bool
isInfixOf [a]
input) [[a]]
completions

-- | Modify 'XMonad.Hooks.StatusBar.PP.PP'\'s pretty-printing format to show
-- workspace names as well.
workspaceNamesPP :: PP -> X PP
workspaceNamesPP :: PP -> X PP
workspaceNamesPP PP
pp = WorkspaceId -> X (WorkspaceId -> WindowSpace -> WorkspaceId)
getWorkspaceNames WorkspaceId
":" forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \WorkspaceId -> WindowSpace -> WorkspaceId
ren -> PP
pp{ ppRename :: WorkspaceId -> WindowSpace -> WorkspaceId
ppRename = PP -> WorkspaceId -> WindowSpace -> WorkspaceId
ppRename PP
pp forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> WorkspaceId -> WindowSpace -> WorkspaceId
ren }

-- | Tell "XMonad.Hooks.EwmhDesktops" to append workspace names to desktop
-- names.
workspaceNamesEwmh :: XConfig l -> XConfig l
workspaceNamesEwmh :: forall (l :: * -> *). XConfig l -> XConfig l
workspaceNamesEwmh = forall (l :: * -> *).
X (WorkspaceId -> WindowSpace -> WorkspaceId)
-> XConfig l -> XConfig l
addEwmhWorkspaceRename forall a b. (a -> b) -> a -> b
$ WorkspaceId -> X (WorkspaceId -> WindowSpace -> WorkspaceId)
getWorkspaceNames WorkspaceId
":"