-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Actions.LinkWorkspaces
-- Description : Bindings to add and delete links between workspaces.
-- Copyright   :  (c) Jan-David Quesel <quesel@gmail.org>
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  none
-- Stability   :  unstable
-- Portability :  unportable
--
-- Provides bindings to add and delete links between workspaces. It is aimed
-- at providing useful links between workspaces in a multihead setup. Linked
-- workspaces are view at the same time.
--
-----------------------------------------------------------------------------

module XMonad.Actions.LinkWorkspaces (
                                         -- * Usage
                                         -- $usage
                                        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 )

-- $usage
-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@ file:
--
-- > import XMonad.Actions.LinkWorkspaces
--
-- and add a function to print messages like
--
-- > message_command (S screen) = " dzen2 -p 1 -w 300 -xs " ++ show (screen + 1)
-- > message_color_func c1 c2 msg = dzenColor c1 c2 msg
-- > message screen c1 c2 msg = spawn $ "echo '" ++ (message_color_func c1 c2 msg) ++ "' | " ++ message_command screen
--
-- alternatively you can use the noMessages function as the argument
--
-- Then add keybindings like the following:
--
-- > ,((modm, xK_p), toggleLinkWorkspaces message)
-- > ,((modm .|. shiftMask, xK_p), removeAllMatchings message)
--
-- >   [ ((modm .|. m, k), a i)
-- >       | (a, m) <- [(switchWS (\y -> windows $ view y) message, 0),(switchWS (\x -> windows $ shift x . view x) message, shiftMask)]
-- >       , (i, k) <- zip (XMonad.workspaces conf) [xK_1 .. xK_9]]
--
-- For detailed instructions on editing your key bindings, see
-- "XMonad.Doc.Extending#Editing_key_bindings".

data MessageConfig = MessageConfig {  MessageConfig -> ScreenId -> [Char] -> [Char] -> [Char] -> X ()
messageFunction :: ScreenId -> [Char] -> [Char] -> [Char] -> X()
                    , MessageConfig -> [Char]
foreground :: [Char]
                    , MessageConfig -> [Char]
alertedForeground :: [Char]
                    , MessageConfig -> [Char]
background :: [Char]
                   }

defaultMessageConf :: MessageConfig
defaultMessageConf :: MessageConfig
defaultMessageConf = MessageConfig :: (ScreenId -> [Char] -> [Char] -> [Char] -> X ())
-> [Char] -> [Char] -> [Char] -> MessageConfig
MessageConfig { messageFunction :: ScreenId -> [Char] -> [Char] -> [Char] -> X ()
messageFunction = ScreenId -> [Char] -> [Char] -> [Char] -> X ()
noMessageFn
                     , background :: [Char]
background = [Char]
"#000000"
                     , alertedForeground :: [Char]
alertedForeground = [Char]
"#ff7701"
                     , foreground :: [Char]
foreground = [Char]
"#00ff00" }

noMessageFn :: ScreenId -> [Char] -> [Char] -> [Char] -> X()
noMessageFn :: ScreenId -> [Char] -> [Char] -> [Char] -> X ()
noMessageFn ScreenId
_ [Char]
_ [Char]
_ [Char]
_ = () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return () :: X ()

-- | Stuff for linking workspaces
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
readListPrec :: ReadPrec [WorkspaceMap]
$creadListPrec :: ReadPrec [WorkspaceMap]
readPrec :: ReadPrec WorkspaceMap
$creadPrec :: ReadPrec WorkspaceMap
readList :: ReadS [WorkspaceMap]
$creadList :: ReadS [WorkspaceMap]
readsPrec :: Int -> ReadS WorkspaceMap
$creadsPrec :: Int -> ReadS WorkspaceMap
Read, Int -> WorkspaceMap -> ShowS
[WorkspaceMap] -> ShowS
WorkspaceMap -> [Char]
(Int -> WorkspaceMap -> ShowS)
-> (WorkspaceMap -> [Char])
-> ([WorkspaceMap] -> ShowS)
-> Show WorkspaceMap
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [WorkspaceMap] -> ShowS
$cshowList :: [WorkspaceMap] -> ShowS
show :: WorkspaceMap -> [Char]
$cshow :: WorkspaceMap -> [Char]
showsPrec :: Int -> WorkspaceMap -> ShowS
$cshowsPrec :: Int -> WorkspaceMap -> ShowS
Show)
instance ExtensionClass WorkspaceMap
    where initialValue :: WorkspaceMap
initialValue = Map [Char] [Char] -> WorkspaceMap
WorkspaceMap Map [Char] [Char]
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 :: ([Char] -> X ()) -> MessageConfig -> [Char] -> X ()
switchWS [Char] -> X ()
f MessageConfig
m [Char]
ws = ([Char] -> X ())
-> MessageConfig -> [Char] -> Maybe ScreenId -> X ()
switchWS' [Char] -> X ()
f MessageConfig
m [Char]
ws Maybe ScreenId
forall a. Maybe a
Nothing

-- | Switch to the given workspace in a non greedy way, stop if we reached the first screen
-- | we already did switching on
switchWS' :: (WorkspaceId -> X ()) -> MessageConfig  -> WorkspaceId -> Maybe ScreenId -> X ()
switchWS' :: ([Char] -> X ())
-> MessageConfig -> [Char] -> Maybe ScreenId -> X ()
switchWS' [Char] -> X ()
switchFn MessageConfig
message [Char]
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 [Char] (Layout Window) Window ScreenId ScreenDetail
-> ScreenId
forall i l a sid sd. Screen i l a sid sd -> sid
W.screen (WindowSet
-> Screen [Char] (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
  [Char] -> X ()
switchFn [Char]
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 (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 = ([Char] -> Maybe ScreenId -> X ())
-> MessageConfig
-> [Char]
-> ScreenId
-> ScreenId
-> Maybe ScreenId
-> X ()
switchToMatching (([Char] -> X ())
-> MessageConfig -> [Char] -> Maybe ScreenId -> X ()
switchWS' [Char] -> X ()
switchFn MessageConfig
message) MessageConfig
message [Char]
workspace

-- | Switch to the workspace that matches the current one, executing switches for that workspace as well.
-- | The function switchWorkspaceNonGreedy' will take of stopping if we reached the first workspace again.
switchToMatching :: (WorkspaceId -> Maybe ScreenId -> X ()) -> MessageConfig -> WorkspaceId -> ScreenId
    -> ScreenId -> Maybe ScreenId -> X ()
switchToMatching :: ([Char] -> Maybe ScreenId -> X ())
-> MessageConfig
-> [Char]
-> ScreenId
-> ScreenId
-> Maybe ScreenId
-> X ()
switchToMatching [Char] -> Maybe ScreenId -> X ()
f MessageConfig
message [Char]
t ScreenId
now ScreenId
next Maybe ScreenId
stopAtScreen = do
    WorkspaceMap Map [Char] [Char]
matchings <- X WorkspaceMap
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get :: X WorkspaceMap
    case [Char] -> Map [Char] [Char] -> Maybe [Char]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup [Char]
t Map [Char] [Char]
matchings of
        Maybe [Char]
Nothing -> () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return () :: X()
        Just [Char]
newWorkspace -> do
            X () -> Focus -> ScreenId -> X ()
onScreen' ([Char] -> Maybe ScreenId -> X ()
f [Char]
newWorkspace Maybe ScreenId
stopAtScreen) Focus
FocusCurrent ScreenId
next
            MessageConfig -> ScreenId -> [Char] -> [Char] -> [Char] -> X ()
messageFunction MessageConfig
message ScreenId
now (MessageConfig -> [Char]
foreground MessageConfig
message) (MessageConfig -> [Char]
background MessageConfig
message) ([Char]
"Switching to: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ([Char]
t [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" and " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
newWorkspace))

-- | Insert a mapping between t1 and t2 or remove it was already present
toggleMatching :: MessageConfig -> WorkspaceId -> WorkspaceId -> X ()
toggleMatching :: MessageConfig -> [Char] -> [Char] -> X ()
toggleMatching MessageConfig
message [Char]
t1 [Char]
t2 = do
    WorkspaceMap Map [Char] [Char]
matchings <- X WorkspaceMap
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get :: X WorkspaceMap
    case [Char] -> Map [Char] [Char] -> Maybe [Char]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup [Char]
t1 Map [Char] [Char]
matchings of
        Maybe [Char]
Nothing -> MessageConfig -> [Char] -> [Char] -> Map [Char] [Char] -> X ()
setMatching MessageConfig
message [Char]
t1 [Char]
t2 Map [Char] [Char]
matchings
        Just [Char]
t -> if [Char]
t [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
t2 then MessageConfig -> [Char] -> [Char] -> Map [Char] [Char] -> X ()
removeMatching' MessageConfig
message [Char]
t1 [Char]
t2 Map [Char] [Char]
matchings else MessageConfig -> [Char] -> [Char] -> Map [Char] [Char] -> X ()
setMatching MessageConfig
message [Char]
t1 [Char]
t2 Map [Char] [Char]
matchings
    () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Insert a mapping between t1 and t2 and display a message
setMatching :: MessageConfig -> WorkspaceId -> WorkspaceId -> M.Map WorkspaceId WorkspaceId -> X ()
setMatching :: MessageConfig -> [Char] -> [Char] -> Map [Char] [Char] -> X ()
setMatching MessageConfig
message [Char]
t1 [Char]
t2 Map [Char] [Char]
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 [Char] (Layout Window) Window ScreenId ScreenDetail
-> ScreenId
forall i l a sid sd. Screen i l a sid sd -> sid
W.screen (WindowSet
-> Screen [Char] (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 [Char] [Char] -> WorkspaceMap
WorkspaceMap (Map [Char] [Char] -> WorkspaceMap)
-> Map [Char] [Char] -> WorkspaceMap
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> Map [Char] [Char] -> Map [Char] [Char]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert [Char]
t1 [Char]
t2 Map [Char] [Char]
matchings
   MessageConfig -> ScreenId -> [Char] -> [Char] -> [Char] -> X ()
messageFunction MessageConfig
message ScreenId
now (MessageConfig -> [Char]
foreground MessageConfig
message) (MessageConfig -> [Char]
background MessageConfig
message) ([Char]
"Linked: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ ([Char]
t1 [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
t2))

-- currently this function is called manually this means that if workspaces
-- were deleted, some links stay in the RAM even though they are not used
-- anymore... because of the small amount of memory used for those there is no
-- special cleanup so far
removeMatching' :: MessageConfig -> WorkspaceId -> WorkspaceId -> M.Map WorkspaceId WorkspaceId -> X ()
removeMatching' :: MessageConfig -> [Char] -> [Char] -> Map [Char] [Char] -> X ()
removeMatching' MessageConfig
message [Char]
t1 [Char]
t2 Map [Char] [Char]
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 [Char] (Layout Window) Window ScreenId ScreenDetail
-> ScreenId
forall i l a sid sd. Screen i l a sid sd -> sid
W.screen (WindowSet
-> Screen [Char] (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 [Char] [Char] -> WorkspaceMap
WorkspaceMap (Map [Char] [Char] -> WorkspaceMap)
-> Map [Char] [Char] -> WorkspaceMap
forall a b. (a -> b) -> a -> b
$ [Char] -> Map [Char] [Char] -> Map [Char] [Char]
forall k a. Ord k => k -> Map k a -> Map k a
M.delete [Char]
t1 Map [Char] [Char]
matchings
   MessageConfig -> ScreenId -> [Char] -> [Char] -> [Char] -> X ()
messageFunction MessageConfig
message ScreenId
now (MessageConfig -> [Char]
alertedForeground MessageConfig
message) (MessageConfig -> [Char]
background MessageConfig
message) ([Char]
"Unlinked: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
t1 [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
t2)

-- | Remove all maps between workspaces
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 [Char] (Layout Window) Window ScreenId ScreenDetail
-> ScreenId
forall i l a sid sd. Screen i l a sid sd -> sid
W.screen (WindowSet
-> Screen [Char] (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 [Char] [Char] -> WorkspaceMap
WorkspaceMap Map [Char] [Char]
forall k a. Map k a
M.empty
   MessageConfig -> ScreenId -> [Char] -> [Char] -> [Char] -> X ()
messageFunction MessageConfig
message ScreenId
now (MessageConfig -> [Char]
alertedForeground MessageConfig
message) (MessageConfig -> [Char]
background MessageConfig
message) [Char]
"All links removed!"

-- | remove all matching regarding a given workspace
unMatch :: WorkspaceId -> X ()
unMatch :: [Char] -> X ()
unMatch [Char]
workspace = do
    WorkspaceMap Map [Char] [Char]
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 [Char] [Char] -> WorkspaceMap
WorkspaceMap (Map [Char] [Char] -> WorkspaceMap)
-> Map [Char] [Char] -> WorkspaceMap
forall a b. (a -> b) -> a -> b
$ [Char] -> Map [Char] [Char] -> Map [Char] [Char]
forall k a. Ord k => k -> Map k a -> Map k a
M.delete [Char]
workspace (([Char] -> Bool) -> Map [Char] [Char] -> Map [Char] [Char]
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter ([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
workspace) Map [Char] [Char]
matchings)

-- | Toggle the currently displayed workspaces as matching. Starting from the one with focus
-- | a linked list of workspaces is created that will later be iterated by switchToMatching.
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 [Char] (Layout Window) Window ScreenId ScreenDetail
-> ScreenId
forall i l a sid sd. Screen i l a sid sd -> sid
W.screen (WindowSet
-> Screen [Char] (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 [Char] (Layout Window) Window ScreenId ScreenDetail
-> ScreenId
forall i l a sid sd. Screen i l a sid sd -> sid
W.screen (WindowSet
-> Screen [Char] (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 (m :: * -> *) a. Monad m => a -> m a
return () else do -- this is also the case if there is only one screen
        Maybe [Char] -> ([Char] -> X ()) -> X ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (ScreenId -> WindowSet -> Maybe [Char]
forall s i l a sd. Eq s => s -> StackSet i l a s sd -> Maybe i
W.lookupWorkspace ScreenId
next WindowSet
ws)
             (MessageConfig -> [Char] -> [Char] -> X ()
toggleMatching MessageConfig
message (WindowSet -> [Char]
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