module XMonad.Actions.LinkWorkspaces (
switchWS,
removeAllMatchings,
unMatch,
toggleLinkWorkspaces,
defaultMessageConf,
MessageConfig(..)
) where
import XMonad
import XMonad.Prelude (for_)
import qualified XMonad.StackSet as W
import XMonad.Layout.IndependentScreens(countScreens)
import qualified XMonad.Util.ExtensibleState as XS (get, put)
import XMonad.Actions.OnScreen(Focus(FocusCurrent), onScreen')
import qualified Data.Map as M
( insert, delete, Map, lookup, empty, filter )
data MessageConfig = MessageConfig { MessageConfig
-> ScreenId -> WorkspaceId -> WorkspaceId -> WorkspaceId -> X ()
messageFunction :: ScreenId -> [Char] -> [Char] -> [Char] -> X()
, MessageConfig -> WorkspaceId
foreground :: [Char]
, MessageConfig -> WorkspaceId
alertedForeground :: [Char]
, MessageConfig -> WorkspaceId
background :: [Char]
}
defaultMessageConf :: MessageConfig
defaultMessageConf :: MessageConfig
defaultMessageConf = MessageConfig { messageFunction :: ScreenId -> WorkspaceId -> WorkspaceId -> WorkspaceId -> X ()
messageFunction = ScreenId -> WorkspaceId -> WorkspaceId -> WorkspaceId -> X ()
noMessageFn
, background :: WorkspaceId
background = WorkspaceId
"#000000"
, alertedForeground :: WorkspaceId
alertedForeground = WorkspaceId
"#ff7701"
, foreground :: WorkspaceId
foreground = WorkspaceId
"#00ff00" }
noMessageFn :: ScreenId -> [Char] -> [Char] -> [Char] -> X()
noMessageFn :: ScreenId -> WorkspaceId -> WorkspaceId -> WorkspaceId -> X ()
noMessageFn ScreenId
_ WorkspaceId
_ WorkspaceId
_ WorkspaceId
_ = () -> X ()
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return () :: X ()
newtype WorkspaceMap = WorkspaceMap (M.Map WorkspaceId WorkspaceId) deriving (ReadPrec [WorkspaceMap]
ReadPrec WorkspaceMap
Int -> ReadS WorkspaceMap
ReadS [WorkspaceMap]
(Int -> ReadS WorkspaceMap)
-> ReadS [WorkspaceMap]
-> ReadPrec WorkspaceMap
-> ReadPrec [WorkspaceMap]
-> Read WorkspaceMap
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS WorkspaceMap
readsPrec :: Int -> ReadS WorkspaceMap
$creadList :: ReadS [WorkspaceMap]
readList :: ReadS [WorkspaceMap]
$creadPrec :: ReadPrec WorkspaceMap
readPrec :: ReadPrec WorkspaceMap
$creadListPrec :: ReadPrec [WorkspaceMap]
readListPrec :: ReadPrec [WorkspaceMap]
Read, Int -> WorkspaceMap -> ShowS
[WorkspaceMap] -> ShowS
WorkspaceMap -> WorkspaceId
(Int -> WorkspaceMap -> ShowS)
-> (WorkspaceMap -> WorkspaceId)
-> ([WorkspaceMap] -> ShowS)
-> Show WorkspaceMap
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WorkspaceMap -> ShowS
showsPrec :: Int -> WorkspaceMap -> ShowS
$cshow :: WorkspaceMap -> WorkspaceId
show :: WorkspaceMap -> WorkspaceId
$cshowList :: [WorkspaceMap] -> ShowS
showList :: [WorkspaceMap] -> ShowS
Show)
instance ExtensionClass WorkspaceMap
where initialValue :: WorkspaceMap
initialValue = Map WorkspaceId WorkspaceId -> WorkspaceMap
WorkspaceMap Map WorkspaceId WorkspaceId
forall k a. Map k a
M.empty
extensionType :: WorkspaceMap -> StateExtension
extensionType = WorkspaceMap -> StateExtension
forall a. (Read a, Show a, ExtensionClass a) => a -> StateExtension
PersistentExtension
switchWS :: (WorkspaceId -> X ()) -> MessageConfig -> WorkspaceId -> X ()
switchWS :: (WorkspaceId -> X ()) -> MessageConfig -> WorkspaceId -> X ()
switchWS WorkspaceId -> X ()
f MessageConfig
m WorkspaceId
ws = (WorkspaceId -> X ())
-> MessageConfig -> WorkspaceId -> Maybe ScreenId -> X ()
switchWS' WorkspaceId -> X ()
f MessageConfig
m WorkspaceId
ws Maybe ScreenId
forall a. Maybe a
Nothing
switchWS' :: (WorkspaceId -> X ()) -> MessageConfig -> WorkspaceId -> Maybe ScreenId -> X ()
switchWS' :: (WorkspaceId -> X ())
-> MessageConfig -> WorkspaceId -> Maybe ScreenId -> X ()
switchWS' WorkspaceId -> X ()
switchFn MessageConfig
message WorkspaceId
workspace Maybe ScreenId
stopAtScreen = do
WindowSet
ws <- (XState -> WindowSet) -> X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
ScreenId
nScreens <- X ScreenId
forall (m :: * -> *) i. (MonadIO m, Integral i) => m i
countScreens
let now :: ScreenId
now = Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> ScreenId
forall i l a sid sd. Screen i l a sid sd -> sid
W.screen (WindowSet
-> Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current WindowSet
ws)
let next :: ScreenId
next = (ScreenId
now ScreenId -> ScreenId -> ScreenId
forall a. Num a => a -> a -> a
+ ScreenId
1) ScreenId -> ScreenId -> ScreenId
forall a. Integral a => a -> a -> a
`mod` ScreenId
nScreens
WorkspaceId -> X ()
switchFn WorkspaceId
workspace
case Maybe ScreenId
stopAtScreen of
Maybe ScreenId
Nothing -> ScreenId -> ScreenId -> Maybe ScreenId -> X ()
sTM ScreenId
now ScreenId
next (ScreenId -> Maybe ScreenId
forall a. a -> Maybe a
Just ScreenId
now)
Just ScreenId
sId -> if ScreenId
sId ScreenId -> ScreenId -> Bool
forall a. Eq a => a -> a -> Bool
== ScreenId
next then () -> X ()
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return () else ScreenId -> ScreenId -> Maybe ScreenId -> X ()
sTM ScreenId
now ScreenId
next (ScreenId -> Maybe ScreenId
forall a. a -> Maybe a
Just ScreenId
sId)
where sTM :: ScreenId -> ScreenId -> Maybe ScreenId -> X ()
sTM = (WorkspaceId -> Maybe ScreenId -> X ())
-> MessageConfig
-> WorkspaceId
-> ScreenId
-> ScreenId
-> Maybe ScreenId
-> X ()
switchToMatching ((WorkspaceId -> X ())
-> MessageConfig -> WorkspaceId -> Maybe ScreenId -> X ()
switchWS' WorkspaceId -> X ()
switchFn MessageConfig
message) MessageConfig
message WorkspaceId
workspace
switchToMatching :: (WorkspaceId -> Maybe ScreenId -> X ()) -> MessageConfig -> WorkspaceId -> ScreenId
-> ScreenId -> Maybe ScreenId -> X ()
switchToMatching :: (WorkspaceId -> Maybe ScreenId -> X ())
-> MessageConfig
-> WorkspaceId
-> ScreenId
-> ScreenId
-> Maybe ScreenId
-> X ()
switchToMatching WorkspaceId -> Maybe ScreenId -> X ()
f MessageConfig
message WorkspaceId
t ScreenId
now ScreenId
next Maybe ScreenId
stopAtScreen = do
WorkspaceMap Map WorkspaceId WorkspaceId
matchings <- X WorkspaceMap
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get :: X WorkspaceMap
case WorkspaceId -> Map WorkspaceId WorkspaceId -> Maybe WorkspaceId
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup WorkspaceId
t Map WorkspaceId WorkspaceId
matchings of
Maybe WorkspaceId
Nothing -> () -> X ()
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return () :: X()
Just WorkspaceId
newWorkspace -> do
X () -> Focus -> ScreenId -> X ()
onScreen' (WorkspaceId -> Maybe ScreenId -> X ()
f WorkspaceId
newWorkspace Maybe ScreenId
stopAtScreen) Focus
FocusCurrent ScreenId
next
MessageConfig
-> ScreenId -> WorkspaceId -> WorkspaceId -> WorkspaceId -> X ()
messageFunction MessageConfig
message ScreenId
now (MessageConfig -> WorkspaceId
foreground MessageConfig
message) (MessageConfig -> WorkspaceId
background MessageConfig
message) (WorkspaceId
"Switching to: " WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ (WorkspaceId
t WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ WorkspaceId
" and " WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ WorkspaceId
newWorkspace))
toggleMatching :: MessageConfig -> WorkspaceId -> WorkspaceId -> X ()
toggleMatching :: MessageConfig -> WorkspaceId -> WorkspaceId -> X ()
toggleMatching MessageConfig
message WorkspaceId
t1 WorkspaceId
t2 = do
WorkspaceMap Map WorkspaceId WorkspaceId
matchings <- X WorkspaceMap
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get :: X WorkspaceMap
case WorkspaceId -> Map WorkspaceId WorkspaceId -> Maybe WorkspaceId
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup WorkspaceId
t1 Map WorkspaceId WorkspaceId
matchings of
Maybe WorkspaceId
Nothing -> MessageConfig
-> WorkspaceId
-> WorkspaceId
-> Map WorkspaceId WorkspaceId
-> X ()
setMatching MessageConfig
message WorkspaceId
t1 WorkspaceId
t2 Map WorkspaceId WorkspaceId
matchings
Just WorkspaceId
t -> if WorkspaceId
t WorkspaceId -> WorkspaceId -> Bool
forall a. Eq a => a -> a -> Bool
== WorkspaceId
t2 then MessageConfig
-> WorkspaceId
-> WorkspaceId
-> Map WorkspaceId WorkspaceId
-> X ()
removeMatching' MessageConfig
message WorkspaceId
t1 WorkspaceId
t2 Map WorkspaceId WorkspaceId
matchings else MessageConfig
-> WorkspaceId
-> WorkspaceId
-> Map WorkspaceId WorkspaceId
-> X ()
setMatching MessageConfig
message WorkspaceId
t1 WorkspaceId
t2 Map WorkspaceId WorkspaceId
matchings
() -> X ()
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
setMatching :: MessageConfig -> WorkspaceId -> WorkspaceId -> M.Map WorkspaceId WorkspaceId -> X ()
setMatching :: MessageConfig
-> WorkspaceId
-> WorkspaceId
-> Map WorkspaceId WorkspaceId
-> X ()
setMatching MessageConfig
message WorkspaceId
t1 WorkspaceId
t2 Map WorkspaceId WorkspaceId
matchings = do
WindowSet
ws <- (XState -> WindowSet) -> X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
let now :: ScreenId
now = Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> ScreenId
forall i l a sid sd. Screen i l a sid sd -> sid
W.screen (WindowSet
-> Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current WindowSet
ws)
WorkspaceMap -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (WorkspaceMap -> X ()) -> WorkspaceMap -> X ()
forall a b. (a -> b) -> a -> b
$ Map WorkspaceId WorkspaceId -> WorkspaceMap
WorkspaceMap (Map WorkspaceId WorkspaceId -> WorkspaceMap)
-> Map WorkspaceId WorkspaceId -> WorkspaceMap
forall a b. (a -> b) -> a -> b
$ WorkspaceId
-> WorkspaceId
-> Map WorkspaceId WorkspaceId
-> Map WorkspaceId WorkspaceId
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert WorkspaceId
t1 WorkspaceId
t2 Map WorkspaceId WorkspaceId
matchings
MessageConfig
-> ScreenId -> WorkspaceId -> WorkspaceId -> WorkspaceId -> X ()
messageFunction MessageConfig
message ScreenId
now (MessageConfig -> WorkspaceId
foreground MessageConfig
message) (MessageConfig -> WorkspaceId
background MessageConfig
message) (WorkspaceId
"Linked: " WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ (WorkspaceId
t1 WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ WorkspaceId
" " WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ WorkspaceId
t2))
removeMatching' :: MessageConfig -> WorkspaceId -> WorkspaceId -> M.Map WorkspaceId WorkspaceId -> X ()
removeMatching' :: MessageConfig
-> WorkspaceId
-> WorkspaceId
-> Map WorkspaceId WorkspaceId
-> X ()
removeMatching' MessageConfig
message WorkspaceId
t1 WorkspaceId
t2 Map WorkspaceId WorkspaceId
matchings = do
WindowSet
ws <- (XState -> WindowSet) -> X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
let now :: ScreenId
now = Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> ScreenId
forall i l a sid sd. Screen i l a sid sd -> sid
W.screen (WindowSet
-> Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current WindowSet
ws)
WorkspaceMap -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (WorkspaceMap -> X ()) -> WorkspaceMap -> X ()
forall a b. (a -> b) -> a -> b
$ Map WorkspaceId WorkspaceId -> WorkspaceMap
WorkspaceMap (Map WorkspaceId WorkspaceId -> WorkspaceMap)
-> Map WorkspaceId WorkspaceId -> WorkspaceMap
forall a b. (a -> b) -> a -> b
$ WorkspaceId
-> Map WorkspaceId WorkspaceId -> Map WorkspaceId WorkspaceId
forall k a. Ord k => k -> Map k a -> Map k a
M.delete WorkspaceId
t1 Map WorkspaceId WorkspaceId
matchings
MessageConfig
-> ScreenId -> WorkspaceId -> WorkspaceId -> WorkspaceId -> X ()
messageFunction MessageConfig
message ScreenId
now (MessageConfig -> WorkspaceId
alertedForeground MessageConfig
message) (MessageConfig -> WorkspaceId
background MessageConfig
message) (WorkspaceId
"Unlinked: " WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ WorkspaceId
t1 WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ WorkspaceId
" " WorkspaceId -> ShowS
forall a. [a] -> [a] -> [a]
++ WorkspaceId
t2)
removeAllMatchings :: MessageConfig -> X ()
removeAllMatchings :: MessageConfig -> X ()
removeAllMatchings MessageConfig
message = do
WindowSet
ws <- (XState -> WindowSet) -> X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
let now :: ScreenId
now = Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> ScreenId
forall i l a sid sd. Screen i l a sid sd -> sid
W.screen (WindowSet
-> Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current WindowSet
ws)
WorkspaceMap -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (WorkspaceMap -> X ()) -> WorkspaceMap -> X ()
forall a b. (a -> b) -> a -> b
$ Map WorkspaceId WorkspaceId -> WorkspaceMap
WorkspaceMap Map WorkspaceId WorkspaceId
forall k a. Map k a
M.empty
MessageConfig
-> ScreenId -> WorkspaceId -> WorkspaceId -> WorkspaceId -> X ()
messageFunction MessageConfig
message ScreenId
now (MessageConfig -> WorkspaceId
alertedForeground MessageConfig
message) (MessageConfig -> WorkspaceId
background MessageConfig
message) WorkspaceId
"All links removed!"
unMatch :: WorkspaceId -> X ()
unMatch :: WorkspaceId -> X ()
unMatch WorkspaceId
workspace = do
WorkspaceMap Map WorkspaceId WorkspaceId
matchings <- X WorkspaceMap
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get :: X WorkspaceMap
WorkspaceMap -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (WorkspaceMap -> X ()) -> WorkspaceMap -> X ()
forall a b. (a -> b) -> a -> b
$ Map WorkspaceId WorkspaceId -> WorkspaceMap
WorkspaceMap (Map WorkspaceId WorkspaceId -> WorkspaceMap)
-> Map WorkspaceId WorkspaceId -> WorkspaceMap
forall a b. (a -> b) -> a -> b
$ WorkspaceId
-> Map WorkspaceId WorkspaceId -> Map WorkspaceId WorkspaceId
forall k a. Ord k => k -> Map k a -> Map k a
M.delete WorkspaceId
workspace ((WorkspaceId -> Bool)
-> Map WorkspaceId WorkspaceId -> Map WorkspaceId WorkspaceId
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (WorkspaceId -> WorkspaceId -> Bool
forall a. Eq a => a -> a -> Bool
/= WorkspaceId
workspace) Map WorkspaceId WorkspaceId
matchings)
toggleLinkWorkspaces :: MessageConfig -> X ()
toggleLinkWorkspaces :: MessageConfig -> X ()
toggleLinkWorkspaces MessageConfig
message = (WindowSet -> X ()) -> X ()
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X ()) -> X ()) -> (WindowSet -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \WindowSet
ws -> ScreenId -> MessageConfig -> X ()
toggleLinkWorkspaces' (Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> ScreenId
forall i l a sid sd. Screen i l a sid sd -> sid
W.screen (WindowSet
-> Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current WindowSet
ws)) MessageConfig
message
toggleLinkWorkspaces' :: ScreenId -> MessageConfig -> X ()
toggleLinkWorkspaces' :: ScreenId -> MessageConfig -> X ()
toggleLinkWorkspaces' ScreenId
first MessageConfig
message = do
WindowSet
ws <- (XState -> WindowSet) -> X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
ScreenId
nScreens <- X ScreenId
forall (m :: * -> *) i. (MonadIO m, Integral i) => m i
countScreens
let now :: ScreenId
now = Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> ScreenId
forall i l a sid sd. Screen i l a sid sd -> sid
W.screen (WindowSet
-> Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current WindowSet
ws)
let next :: ScreenId
next = (ScreenId
now ScreenId -> ScreenId -> ScreenId
forall a. Num a => a -> a -> a
+ ScreenId
1) ScreenId -> ScreenId -> ScreenId
forall a. Integral a => a -> a -> a
`mod` ScreenId
nScreens
if ScreenId
next ScreenId -> ScreenId -> Bool
forall a. Eq a => a -> a -> Bool
== ScreenId
first then () -> X ()
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return () else do
Maybe WorkspaceId -> (WorkspaceId -> X ()) -> X ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (ScreenId -> WindowSet -> Maybe WorkspaceId
forall s i l a sd. Eq s => s -> StackSet i l a s sd -> Maybe i
W.lookupWorkspace ScreenId
next WindowSet
ws)
(MessageConfig -> WorkspaceId -> WorkspaceId -> X ()
toggleMatching MessageConfig
message (WindowSet -> WorkspaceId
forall i l a s sd. StackSet i l a s sd -> i
W.currentTag WindowSet
ws))
X () -> Focus -> ScreenId -> X ()
onScreen' (ScreenId -> MessageConfig -> X ()
toggleLinkWorkspaces' ScreenId
first MessageConfig
message) Focus
FocusCurrent ScreenId
next