-----------------------------------------------------------------------------
-- |
-- 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]
(Int -> ReadS WorkspaceNames)
-> ReadS [WorkspaceNames]
-> ReadPrec WorkspaceNames
-> ReadPrec [WorkspaceNames]
-> Read WorkspaceNames
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS WorkspaceNames
readsPrec :: Int -> ReadS WorkspaceNames
$creadList :: ReadS [WorkspaceNames]
readList :: ReadS [WorkspaceNames]
$creadPrec :: ReadPrec WorkspaceNames
readPrec :: ReadPrec WorkspaceNames
$creadListPrec :: ReadPrec [WorkspaceNames]
readListPrec :: ReadPrec [WorkspaceNames]
Read, Int -> WorkspaceNames -> ShowS
[WorkspaceNames] -> ShowS
WorkspaceNames -> WorkspaceId
(Int -> WorkspaceNames -> ShowS)
-> (WorkspaceNames -> WorkspaceId)
-> ([WorkspaceNames] -> ShowS)
-> Show WorkspaceNames
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WorkspaceNames -> ShowS
showsPrec :: Int -> WorkspaceNames -> ShowS
$cshow :: WorkspaceNames -> WorkspaceId
show :: WorkspaceNames -> WorkspaceId
$cshowList :: [WorkspaceNames] -> ShowS
showList :: [WorkspaceNames] -> ShowS
Show)

instance ExtensionClass WorkspaceNames where
    initialValue :: WorkspaceNames
initialValue = Map WorkspaceId WorkspaceId -> WorkspaceNames
WorkspaceNames Map WorkspaceId WorkspaceId
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 (WorkspaceId -> Maybe WorkspaceId)
getWorkspaceNames' = do
    WorkspaceNames m <- X WorkspaceNames
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
    return (`M.lookup` 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 = (WorkspaceId -> Maybe WorkspaceId)
-> WorkspaceId -> WindowSpace -> WorkspaceId
forall {t} {l} {a}.
(t -> Maybe WorkspaceId)
-> WorkspaceId -> Workspace t l a -> WorkspaceId
ren ((WorkspaceId -> Maybe WorkspaceId)
 -> WorkspaceId -> WindowSpace -> WorkspaceId)
-> X (WorkspaceId -> Maybe WorkspaceId)
-> X (WorkspaceId -> WindowSpace -> WorkspaceId)
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 WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ WorkspaceId -> ShowS -> Maybe WorkspaceId -> WorkspaceId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe WorkspaceId
"" (WorkspaceId
sep WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++) (t -> Maybe WorkspaceId
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 :: WorkspaceId -> X (Maybe WorkspaceId)
getWorkspaceName WorkspaceId
w = ((WorkspaceId -> Maybe WorkspaceId)
-> WorkspaceId -> Maybe WorkspaceId
forall a b. (a -> b) -> a -> b
$ WorkspaceId
w) ((WorkspaceId -> Maybe WorkspaceId) -> Maybe WorkspaceId)
-> X (WorkspaceId -> Maybe WorkspaceId) -> X (Maybe WorkspaceId)
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 (WorkspaceId -> X (Maybe WorkspaceId))
-> X WorkspaceId -> X (Maybe WorkspaceId)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (XState -> WorkspaceId) -> X WorkspaceId
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> WorkspaceId
forall i l a s sd. StackSet i l a s sd -> i
W.currentTag (StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
 -> WorkspaceId)
-> (XState
    -> StackSet
         WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> WorkspaceId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet
     WorkspaceId (Layout Window) Window ScreenId ScreenDetail
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 m <- X WorkspaceNames
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
    XS.put $ WorkspaceNames $ if null name then M.delete w m else M.insert w name m
    refresh

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

-- | Prompt for a new name for the current workspace and set it.
renameWorkspace :: XPConfig -> X ()
renameWorkspace :: XPConfig -> X ()
renameWorkspace XPConfig
conf = do
    completion <- XPConfig -> (WorkspaceId -> Bool) -> X ComplFunction
historyCompletionP XPConfig
conf (WorkspaceId
prompt WorkspaceId -> WorkspaceId -> Bool
forall a. Eq a => a -> a -> Bool
==)
    mkXPrompt (Wor prompt) conf completion 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 X WorkspaceId -> (WorkspaceId -> X ()) -> X ()
forall a b. X a -> (a -> X b) -> X b
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
    current <- (XState -> WorkspaceId) -> X WorkspaceId
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> WorkspaceId
forall i l a s sd. StackSet i l a s sd -> i
W.currentTag (StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
 -> WorkspaceId)
-> (XState
    -> StackSet
         WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> WorkspaceId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet
     WorkspaceId (Layout Window) Window ScreenId ScreenDetail
windowset)
    swapNames t current
    windows $ Swap.swapWorkspaces t current

-- | Swap names of the two workspaces.
swapNames :: WorkspaceId -> WorkspaceId -> X ()
swapNames :: WorkspaceId -> WorkspaceId -> X ()
swapNames WorkspaceId
w1 WorkspaceId
w2 = do
    WorkspaceNames m <- X WorkspaceNames
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
    let getname WorkspaceId
w = WorkspaceId -> Maybe WorkspaceId -> WorkspaceId
forall a. a -> Maybe a -> a
fromMaybe WorkspaceId
"" (Maybe WorkspaceId -> WorkspaceId)
-> Maybe WorkspaceId -> WorkspaceId
forall a b. (a -> b) -> a -> b
$ WorkspaceId -> Map WorkspaceId WorkspaceId -> Maybe WorkspaceId
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup WorkspaceId
w Map WorkspaceId WorkspaceId
m
        set k
w t a
name Map k (t a)
m' = if t a -> Bool
forall a. 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'
    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 -> (WorkspaceId -> X ()) -> X ()
workspaceNamePrompt :: XPConfig -> (WorkspaceId -> X ()) -> X ()
workspaceNamePrompt XPConfig
conf WorkspaceId -> X ()
job = do
    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 WorkspaceId (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 WorkspaceId (Layout Window) Window ScreenId ScreenDetail
 -> [WindowSpace])
-> (XState
    -> StackSet
         WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> [WindowSpace]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet
     WorkspaceId (Layout Window) Window ScreenId ScreenDetail
windowset
    myWorkspacesName <- getWorkspaceNames ":" <&> \WorkspaceId -> WindowSpace -> WorkspaceId
n -> [WorkspaceId -> WindowSpace -> WorkspaceId
n (WindowSpace -> WorkspaceId
forall i l a. Workspace i l a -> i
W.tag WindowSpace
w) WindowSpace
w | WindowSpace
w <- [WindowSpace]
myWorkspaces]
    let pairs = [WorkspaceId] -> [WorkspaceId] -> [(WorkspaceId, WorkspaceId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [WorkspaceId]
myWorkspacesName ((WindowSpace -> WorkspaceId) -> [WindowSpace] -> [WorkspaceId]
forall a b. (a -> b) -> [a] -> [b]
map WindowSpace -> WorkspaceId
forall i l a. Workspace i l a -> i
W.tag [WindowSpace]
myWorkspaces)
    mkXPrompt (Wor "Select workspace: ") conf
              (contains myWorkspacesName)
              (job . toWsId pairs)
  where toWsId :: [(a, WorkspaceId)] -> a -> WorkspaceId
toWsId [(a, WorkspaceId)]
pairs a
name = WorkspaceId -> Maybe WorkspaceId -> WorkspaceId
forall a. a -> Maybe a -> a
fromMaybe WorkspaceId
"" (a -> [(a, WorkspaceId)] -> Maybe 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 =
          [[a]] -> m [[a]]
forall a. 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 = WorkspaceId -> X (WorkspaceId -> WindowSpace -> WorkspaceId)
getWorkspaceNames WorkspaceId
":" X (WorkspaceId -> WindowSpace -> WorkspaceId)
-> ((WorkspaceId -> WindowSpace -> WorkspaceId) -> PP) -> X PP
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \WorkspaceId -> WindowSpace -> WorkspaceId
ren -> PP
pp{ ppRename = ppRename pp >=> 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 = X (WorkspaceId -> WindowSpace -> WorkspaceId)
-> XConfig l -> XConfig l
forall (l :: * -> *).
X (WorkspaceId -> WindowSpace -> WorkspaceId)
-> XConfig l -> XConfig l
addEwmhWorkspaceRename (X (WorkspaceId -> WindowSpace -> WorkspaceId)
 -> XConfig l -> XConfig l)
-> X (WorkspaceId -> WindowSpace -> WorkspaceId)
-> XConfig l
-> XConfig l
forall a b. (a -> b) -> a -> b
$ WorkspaceId -> X (WorkspaceId -> WindowSpace -> WorkspaceId)
getWorkspaceNames WorkspaceId
":"