{-# LANGUAGE DeriveDataTypeable #-}
module XMonad.Actions.WorkspaceNames (
renameWorkspace,
workspaceNamesPP,
getWorkspaceNames',
getWorkspaceNames,
getWorkspaceName,
getCurrentWorkspaceName,
setWorkspaceName,
setCurrentWorkspaceName,
swapTo,
swapTo',
swapWithCurrent,
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)
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
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)
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)
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'
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)
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
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
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: "
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
}
swapTo :: Direction1D -> X ()
swapTo :: Direction1D -> X ()
swapTo dir :: Direction1D
dir = Direction1D -> WSType -> X ()
swapTo' Direction1D
dir WSType
AnyWS
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
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
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
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