-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Actions.WorkspaceNames
-- 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 DynamicLog 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.
--
-----------------------------------------------------------------------------

{-# LANGUAGE DeriveDataTypeable #-}

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

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

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

    -- * Workspace prompt
    workspaceNamePrompt
    ) where

import XMonad
import qualified XMonad.StackSet as W
import qualified XMonad.Util.ExtensibleState as XS

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

import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Data.List (isInfixOf)

-- $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 DynamicLog pretty-printer:
--
-- > myLogHook =
-- >     workspaceNamesPP xmobarPP >>= dynamicLogString >>= xmonadPropLog
--
-- 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 (Typeable, 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 m :: 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 that maps workspace tag @\"t\"@ to @\"t:name\"@ for
-- workspaces with a name, and to @\"t\"@ otherwise.
getWorkspaceNames :: X (WorkspaceId -> String)
getWorkspaceNames :: X ShowS
getWorkspaceNames = do
    String -> Maybe String
lookup <- X (String -> Maybe String)
getWorkspaceNames'
    ShowS -> X ShowS
forall (m :: * -> *) a. Monad m => a -> m a
return (ShowS -> X ShowS) -> ShowS -> X ShowS
forall a b. (a -> b) -> a -> b
$ \wks :: String
wks -> String
wks String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (':' Char -> ShowS
forall a. a -> [a] -> [a]
:) (String -> Maybe String
lookup String
wks)

-- | Gets the name of a workspace, if set, otherwise returns nothing.
getWorkspaceName :: WorkspaceId -> X (Maybe String)
getWorkspaceName :: String -> X (Maybe String)
getWorkspaceName w :: 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
`fmap` X (String -> Maybe String)
getWorkspaceNames'

-- | Gets the name of the current workspace. See 'getWorkspaceName'
getCurrentWorkspaceName :: X (Maybe String)
getCurrentWorkspaceName :: X (Maybe String)
getCurrentWorkspaceName = do
    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 w :: String
w name :: String
name = do
    WorkspaceNames m :: 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 name :: 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 conf :: XPConfig
conf = do
    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 "Workspace name: "

-- | Modify "XMonad.Hooks.DynamicLog"\'s pretty-printing format to show
-- workspace names as well.
workspaceNamesPP :: PP -> X PP
workspaceNamesPP :: PP -> X PP
workspaceNamesPP pp :: PP
pp = do
    ShowS
names <- X ShowS
getWorkspaceNames
    PP -> X PP
forall (m :: * -> *) a. Monad m => a -> m a
return (PP -> X PP) -> PP -> X PP
forall a b. (a -> b) -> a -> b
$
        PP
pp {
            ppCurrent :: ShowS
ppCurrent         = PP -> ShowS
ppCurrent         PP
pp ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
names,
            ppVisible :: ShowS
ppVisible         = PP -> ShowS
ppVisible         PP
pp ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
names,
            ppHidden :: ShowS
ppHidden          = PP -> ShowS
ppHidden          PP
pp ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
names,
            ppHiddenNoWindows :: ShowS
ppHiddenNoWindows = PP -> ShowS
ppHiddenNoWindows PP
pp ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
names,
            ppUrgent :: ShowS
ppUrgent          = PP -> ShowS
ppUrgent          PP
pp ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
names
        }

-- | See 'XMonad.Actions.SwapWorkspaces.swapTo'. This is the same with names.
swapTo :: Direction1D -> X ()
swapTo :: Direction1D -> X ()
swapTo dir :: 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' dir :: Direction1D
dir which :: WSType
which = X WorkspaceSort -> Direction1D -> WSType -> Int -> X String
findWorkspace X WorkspaceSort
getSortByIndex Direction1D
dir WSType
which 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 t :: 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 w1 :: String
w1 w2 :: String
w2 = do
    WorkspaceNames m :: Map String String
m <- X WorkspaceNames
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
    let getname :: ShowS
getname w :: String
w = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "" (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 w :: k
w name :: t a
name m' :: 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 -> Map String String)
-> Map String String -> Map String String
forall a b. (a -> b) -> a -> b
$ Map String String
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 -> (String -> X ()) -> X ()
workspaceNamePrompt conf :: XPConfig
conf job :: String -> X ()
job = do
    [String]
myWorkspaces <- (XState -> [String]) -> X [String]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XState -> [String]) -> X [String])
-> (XState -> [String]) -> X [String]
forall a b. (a -> b) -> a -> b
$ (Workspace String (Layout Window) Window -> String)
-> [Workspace String (Layout Window) Window] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Workspace String (Layout Window) Window -> String
forall i l a. Workspace i l a -> i
W.tag ([Workspace String (Layout Window) Window] -> [String])
-> (XState -> [Workspace String (Layout Window) Window])
-> XState
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSet String (Layout Window) Window ScreenId ScreenDetail
-> [Workspace String (Layout Window) Window]
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
 -> [Workspace String (Layout Window) Window])
-> (XState
    -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> [Workspace String (Layout Window) Window]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet String (Layout Window) Window ScreenId ScreenDetail
windowset
    [String]
myWorkspacesName <- X ShowS
getWorkspaceNames X ShowS -> (ShowS -> X [String]) -> X [String]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \f :: ShowS
f -> [String] -> X [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> X [String]) -> [String] -> X [String]
forall a b. (a -> b) -> a -> b
$ ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
f [String]
myWorkspaces
    let pairs :: [(String, String)]
pairs = [String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
myWorkspacesName [String]
myWorkspaces
    Wor -> XPConfig -> ComplFunction -> (String -> X ()) -> X ()
forall p.
XPrompt p =>
p -> XPConfig -> ComplFunction -> (String -> X ()) -> X ()
mkXPrompt (String -> Wor
Wor "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 pairs :: [(a, String)]
pairs name :: a
name = case a -> [(a, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
name [(a, String)]
pairs of
                                Nothing -> ""
                                Just i :: String
i -> String
i
        contains :: [[a]] -> [a] -> m [[a]]
contains completions :: [[a]]
completions input :: [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
Data.List.isInfixOf [a]
input) [[a]]
completions