-----------------------------------------------------------------------------
-- |
-- 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)
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\/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
-- "XMonad.Doc.Extending#Editing_key_bindings".



-- | Workspace names container.
newtype WorkspaceNames = WorkspaceNames (M.Map WorkspaceId String)
    deriving (ReadPrec [WorkspaceNames]
ReadPrec WorkspaceNames
Int -> ReadS WorkspaceNames
ReadS [WorkspaceNames]
(Int -> ReadS WorkspaceNames)
-> ReadS [WorkspaceNames]
-> ReadPrec WorkspaceNames
-> ReadPrec [WorkspaceNames]
-> Read 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 -> String
(Int -> WorkspaceNames -> ShowS)
-> (WorkspaceNames -> String)
-> ([WorkspaceNames] -> ShowS)
-> Show WorkspaceNames
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WorkspaceNames] -> ShowS
$cshowList :: [WorkspaceNames] -> ShowS
show :: WorkspaceNames -> String
$cshow :: WorkspaceNames -> String
showsPrec :: Int -> WorkspaceNames -> ShowS
$cshowsPrec :: Int -> WorkspaceNames -> ShowS
Show)

instance ExtensionClass WorkspaceNames where
    initialValue :: WorkspaceNames
initialValue = Map String String -> WorkspaceNames
WorkspaceNames Map String String
forall k a. Map k a
M.empty
    extensionType :: WorkspaceNames -> StateExtension
extensionType = WorkspaceNames -> StateExtension
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 (String -> Maybe String)
getWorkspaceNames' = do
    WorkspaceNames Map String String
m <- X WorkspaceNames
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
    (String -> Maybe String) -> X (String -> Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map String String
m)

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

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

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

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

-- | Prompt for a new name for the current workspace and set it.
renameWorkspace :: XPConfig -> X ()
renameWorkspace :: XPConfig -> X ()
renameWorkspace XPConfig
conf =
    Wor -> XPConfig -> ComplFunction -> (String -> X ()) -> X ()
forall p.
XPrompt p =>
p -> XPConfig -> ComplFunction -> (String -> X ()) -> X ()
mkXPrompt Wor
pr XPConfig
conf (IO [String] -> ComplFunction
forall a b. a -> b -> a
const ([String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [])) String -> X ()
setCurrentWorkspaceName
    where pr :: Wor
pr = String -> Wor
Wor String
"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 String
findWorkspace X WorkspaceSort
getSortByIndex Direction1D
dir WSType
which Int
1 X String -> (String -> X ()) -> X ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> X ()
swapWithCurrent

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

-- | Swap names of the two workspaces.
swapNames :: WorkspaceId -> WorkspaceId -> X ()
swapNames :: String -> String -> X ()
swapNames String
w1 String
w2 = do
    WorkspaceNames Map String String
m <- X WorkspaceNames
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
    let getname :: ShowS
getname String
w = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
w Map String String
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 t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
name then k -> Map k (t a) -> Map k (t a)
forall k a. Ord k => k -> Map k a -> Map k a
M.delete k
w Map k (t a)
m' else k -> t a -> Map k (t a) -> Map k (t a)
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'
    WorkspaceNames -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (WorkspaceNames -> X ()) -> WorkspaceNames -> X ()
forall a b. (a -> b) -> a -> b
$ Map String String -> WorkspaceNames
WorkspaceNames (Map String String -> WorkspaceNames)
-> Map String String -> WorkspaceNames
forall a b. (a -> b) -> a -> b
$ String -> String -> Map String String -> Map String String
forall (t :: * -> *) k a.
(Foldable t, Ord k) =>
k -> t a -> Map k (t a) -> Map k (t a)
set String
w1 (ShowS
getname String
w2) (Map String String -> Map String String)
-> Map String String -> Map String String
forall a b. (a -> b) -> a -> b
$ String -> String -> Map String String -> Map String String
forall (t :: * -> *) k a.
(Foldable t, Ord k) =>
k -> t a -> Map k (t a) -> Map k (t a)
set String
w2 (ShowS
getname String
w1) Map String String
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 -> (String -> X ()) -> X ()
workspaceNamePrompt XPConfig
conf String -> X ()
job = do
    [WindowSpace]
myWorkspaces <- (XState -> [WindowSpace]) -> X [WindowSpace]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XState -> [WindowSpace]) -> X [WindowSpace])
-> (XState -> [WindowSpace]) -> X [WindowSpace]
forall a b. (a -> b) -> a -> b
$ StackSet String (Layout Window) Window ScreenId ScreenDetail
-> [WindowSpace]
forall i l a s sd. StackSet i l a s sd -> [Workspace i l a]
W.workspaces (StackSet String (Layout Window) Window ScreenId ScreenDetail
 -> [WindowSpace])
-> (XState
    -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> [WindowSpace]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet String (Layout Window) Window ScreenId ScreenDetail
windowset
    [String]
myWorkspacesName <- String -> X (String -> WindowSpace -> String)
getWorkspaceNames String
":" X (String -> WindowSpace -> String)
-> ((String -> WindowSpace -> String) -> [String]) -> X [String]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \String -> WindowSpace -> String
n -> [String -> WindowSpace -> String
n (WindowSpace -> String
forall i l a. Workspace i l a -> i
W.tag WindowSpace
w) WindowSpace
w | WindowSpace
w <- [WindowSpace]
myWorkspaces]
    let pairs :: [(String, String)]
pairs = [String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
myWorkspacesName ((WindowSpace -> String) -> [WindowSpace] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map WindowSpace -> String
forall i l a. Workspace i l a -> i
W.tag [WindowSpace]
myWorkspaces)
    Wor -> XPConfig -> ComplFunction -> (String -> X ()) -> X ()
forall p.
XPrompt p =>
p -> XPConfig -> ComplFunction -> (String -> X ()) -> X ()
mkXPrompt (String -> Wor
Wor String
"Select workspace: ") XPConfig
conf
              ([String] -> ComplFunction
forall (m :: * -> *) a. (Monad m, Eq a) => [[a]] -> [a] -> m [[a]]
contains [String]
myWorkspacesName)
              (String -> X ()
job (String -> X ()) -> ShowS -> String -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, String)] -> ShowS
forall a. Eq a => [(a, String)] -> a -> String
toWsId [(String, String)]
pairs)
  where toWsId :: [(a, String)] -> a -> String
toWsId [(a, String)]
pairs a
name = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (a -> [(a, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
name [(a, String)]
pairs)
        contains :: [[a]] -> [a] -> m [[a]]
contains [[a]]
completions [a]
input =
          [[a]] -> m [[a]]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[a]] -> m [[a]]) -> [[a]] -> m [[a]]
forall a b. (a -> b) -> a -> b
$ ([a] -> Bool) -> [[a]] -> [[a]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([a] -> [a] -> Bool
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 = String -> X (String -> WindowSpace -> String)
getWorkspaceNames String
":" X (String -> WindowSpace -> String)
-> ((String -> WindowSpace -> String) -> PP) -> X PP
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \String -> WindowSpace -> String
ren -> PP
pp{ ppRename :: String -> WindowSpace -> String
ppRename = PP -> String -> WindowSpace -> String
ppRename PP
pp (String -> WindowSpace -> String)
-> (String -> WindowSpace -> String)
-> String
-> WindowSpace
-> String
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> String -> WindowSpace -> String
ren }

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