-----------------------------------------------------------------------------
-- |
-- 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.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
-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.

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
_ = 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]
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 -> WorkspaceId
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
showList :: [WorkspaceMap] -> ShowS
$cshowList :: [WorkspaceMap] -> ShowS
show :: WorkspaceMap -> WorkspaceId
$cshow :: WorkspaceMap -> WorkspaceId
showsPrec :: Int -> WorkspaceMap -> ShowS
$cshowsPrec :: Int -> WorkspaceMap -> ShowS
Show)
instance ExtensionClass WorkspaceMap
    where initialValue :: WorkspaceMap
initialValue = Map WorkspaceId WorkspaceId -> WorkspaceMap
WorkspaceMap forall k a. Map k a
M.empty
          extensionType :: WorkspaceMap -> StateExtension
extensionType = 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 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' :: (WorkspaceId -> X ())
-> MessageConfig -> WorkspaceId -> Maybe ScreenId -> X ()
switchWS' WorkspaceId -> X ()
switchFn MessageConfig
message WorkspaceId
workspace Maybe ScreenId
stopAtScreen = do
  WindowSet
ws <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
  ScreenId
nScreens <- forall (m :: * -> *) i. (MonadIO m, Integral i) => m i
countScreens
  let now :: ScreenId
now = forall i l a sid sd. Screen i l a sid sd -> sid
W.screen (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 forall a. Num a => a -> a -> a
+ ScreenId
1) 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 (forall a. a -> Maybe a
Just ScreenId
now)
    Just ScreenId
sId -> if ScreenId
sId forall a. Eq a => a -> a -> Bool
== ScreenId
next then forall (m :: * -> *) a. Monad m => a -> m a
return () else ScreenId -> ScreenId -> Maybe ScreenId -> X ()
sTM ScreenId
now ScreenId
next (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

-- | 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 :: (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 <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get :: X WorkspaceMap
    case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup WorkspaceId
t Map WorkspaceId WorkspaceId
matchings of
        Maybe WorkspaceId
Nothing -> 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: " forall a. [a] -> [a] -> [a]
++ (WorkspaceId
t forall a. [a] -> [a] -> [a]
++ WorkspaceId
" and " forall a. [a] -> [a] -> [a]
++ WorkspaceId
newWorkspace))

-- | Insert a mapping between t1 and t2 or remove it was already present
toggleMatching :: MessageConfig -> WorkspaceId -> WorkspaceId -> X ()
toggleMatching :: MessageConfig -> WorkspaceId -> WorkspaceId -> X ()
toggleMatching MessageConfig
message WorkspaceId
t1 WorkspaceId
t2 = do
    WorkspaceMap Map WorkspaceId WorkspaceId
matchings <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get :: X WorkspaceMap
    case 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 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
    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
-> WorkspaceId
-> WorkspaceId
-> Map WorkspaceId WorkspaceId
-> X ()
setMatching MessageConfig
message WorkspaceId
t1 WorkspaceId
t2 Map WorkspaceId WorkspaceId
matchings = do
   WindowSet
ws <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
   let now :: ScreenId
now = forall i l a sid sd. Screen i l a sid sd -> sid
W.screen (forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current WindowSet
ws)
   forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put forall a b. (a -> b) -> a -> b
$ Map WorkspaceId WorkspaceId -> WorkspaceMap
WorkspaceMap forall a b. (a -> b) -> a -> b
$ 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: " forall a. [a] -> [a] -> [a]
++ (WorkspaceId
t1 forall a. [a] -> [a] -> [a]
++ WorkspaceId
" " forall a. [a] -> [a] -> [a]
++ WorkspaceId
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
-> WorkspaceId
-> WorkspaceId
-> Map WorkspaceId WorkspaceId
-> X ()
removeMatching' MessageConfig
message WorkspaceId
t1 WorkspaceId
t2 Map WorkspaceId WorkspaceId
matchings = do
   WindowSet
ws <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
   let now :: ScreenId
now = forall i l a sid sd. Screen i l a sid sd -> sid
W.screen (forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current WindowSet
ws)
   forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put forall a b. (a -> b) -> a -> b
$ Map WorkspaceId WorkspaceId -> WorkspaceMap
WorkspaceMap forall a b. (a -> b) -> a -> b
$ 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: " forall a. [a] -> [a] -> [a]
++ WorkspaceId
t1 forall a. [a] -> [a] -> [a]
++ WorkspaceId
" " forall a. [a] -> [a] -> [a]
++ WorkspaceId
t2)

-- | Remove all maps between workspaces
removeAllMatchings :: MessageConfig -> X ()
removeAllMatchings :: MessageConfig -> X ()
removeAllMatchings MessageConfig
message = do
   WindowSet
ws <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
   let now :: ScreenId
now = forall i l a sid sd. Screen i l a sid sd -> sid
W.screen (forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current WindowSet
ws)
   forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put forall a b. (a -> b) -> a -> b
$ Map WorkspaceId WorkspaceId -> WorkspaceMap
WorkspaceMap 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!"

-- | remove all matching regarding a given workspace
unMatch :: WorkspaceId -> X ()
unMatch :: WorkspaceId -> X ()
unMatch WorkspaceId
workspace = do
    WorkspaceMap Map WorkspaceId WorkspaceId
matchings <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get :: X WorkspaceMap
    forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put forall a b. (a -> b) -> a -> b
$ Map WorkspaceId WorkspaceId -> WorkspaceMap
WorkspaceMap forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Map k a
M.delete WorkspaceId
workspace (forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (forall a. Eq a => a -> a -> Bool
/= WorkspaceId
workspace) Map WorkspaceId WorkspaceId
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 = forall a. (WindowSet -> X a) -> X a
withWindowSet forall a b. (a -> b) -> a -> b
$ \WindowSet
ws -> ScreenId -> MessageConfig -> X ()
toggleLinkWorkspaces' (forall i l a sid sd. Screen i l a sid sd -> sid
W.screen (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 <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
    ScreenId
nScreens <- forall (m :: * -> *) i. (MonadIO m, Integral i) => m i
countScreens
    let now :: ScreenId
now = forall i l a sid sd. Screen i l a sid sd -> sid
W.screen (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 forall a. Num a => a -> a -> a
+ ScreenId
1) forall a. Integral a => a -> a -> a
`mod` ScreenId
nScreens
    if ScreenId
next forall a. Eq a => a -> a -> Bool
== ScreenId
first then forall (m :: * -> *) a. Monad m => a -> m a
return () else do -- this is also the case if there is only one screen
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (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 (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