{-# 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 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
$ \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 String
"" (Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
:) (String -> Maybe String
lookup String
wks)
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
`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 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
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
renameWorkspace :: XPConfig -> X ()
renameWorkspace :: XPConfig -> X ()
renameWorkspace 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 String
"Workspace name: "
workspaceNamesPP :: PP -> X PP
workspaceNamesPP :: PP -> X PP
workspaceNamesPP 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 Direction1D
dir = Direction1D -> WSType -> X ()
swapTo' Direction1D
dir WSType
AnyWS
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
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
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 -> 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 XPConfig
conf 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
>>= \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 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 = case a -> [(a, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
name [(a, String)]
pairs of
Maybe String
Nothing -> String
""
Just String
i -> String
i
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
Data.List.isInfixOf [a]
input) [[a]]
completions