-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Actions.DynamicWorkspaceGroups
-- Description :  Dynamically manage workspace groups in multi-head setups.
-- Copyright   :  (c) Brent Yorgey 2009
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  <byorgey@gmail.com>
-- Stability   :  experimental
-- Portability :  unportable
--
-- Dynamically manage \"workspace groups\", sets of workspaces being
-- used together for some common task or purpose, to allow switching
-- between workspace groups in a single action.  Note that this only
-- makes sense for multi-head setups.
--
-----------------------------------------------------------------------------

module XMonad.Actions.DynamicWorkspaceGroups
    ( -- * Usage
      -- $usage

      WSGroupId

    , addRawWSGroup
    , addWSGroup
    , addCurrentWSGroup
    , forgetWSGroup
    , viewWSGroup

    , promptWSGroupView
    , promptWSGroupAdd
    , promptWSGroupForget

    , WSGPrompt
     -- * TopicSpace Integration
     -- $topics
    , viewTopicGroup
    , promptTopicGroupView
    ) where

import Control.Arrow ((&&&))
import qualified Data.Map as M

import XMonad
import XMonad.Prelude (find, for_)
import qualified XMonad.StackSet as W

import XMonad.Prompt
import qualified XMonad.Util.ExtensibleState as XS
import XMonad.Actions.TopicSpace

-- $usage
-- You can use this module by importing it into your @xmonad.hs@ file:
--
-- > import XMonad.Actions.DynamicWorkspaceGroups
--
-- Then add keybindings like the following (this example uses
-- "XMonad.Util.EZConfig"-style keybindings, but this is not necessary):
--
-- >    , ("M-y n", promptWSGroupAdd myXPConfig "Name this group: ")
-- >    , ("M-y g", promptWSGroupView myXPConfig "Go to group: ")
-- >    , ("M-y d", promptWSGroupForget myXPConfig "Forget group: ")
--

type WSGroup = [(ScreenId,WorkspaceId)]

type WSGroupId = String

newtype WSGroupStorage = WSG { WSGroupStorage -> Map WorkspaceId WSGroup
unWSG :: M.Map WSGroupId WSGroup }
  deriving (ReadPrec [WSGroupStorage]
ReadPrec WSGroupStorage
Int -> ReadS WSGroupStorage
ReadS [WSGroupStorage]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [WSGroupStorage]
$creadListPrec :: ReadPrec [WSGroupStorage]
readPrec :: ReadPrec WSGroupStorage
$creadPrec :: ReadPrec WSGroupStorage
readList :: ReadS [WSGroupStorage]
$creadList :: ReadS [WSGroupStorage]
readsPrec :: Int -> ReadS WSGroupStorage
$creadsPrec :: Int -> ReadS WSGroupStorage
Read, Int -> WSGroupStorage -> ShowS
[WSGroupStorage] -> ShowS
WSGroupStorage -> WorkspaceId
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
showList :: [WSGroupStorage] -> ShowS
$cshowList :: [WSGroupStorage] -> ShowS
show :: WSGroupStorage -> WorkspaceId
$cshow :: WSGroupStorage -> WorkspaceId
showsPrec :: Int -> WSGroupStorage -> ShowS
$cshowsPrec :: Int -> WSGroupStorage -> ShowS
Show)

withWSG :: (M.Map WSGroupId WSGroup -> M.Map WSGroupId WSGroup) -> WSGroupStorage -> WSGroupStorage
withWSG :: (Map WorkspaceId WSGroup -> Map WorkspaceId WSGroup)
-> WSGroupStorage -> WSGroupStorage
withWSG Map WorkspaceId WSGroup -> Map WorkspaceId WSGroup
f = Map WorkspaceId WSGroup -> WSGroupStorage
WSG forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map WorkspaceId WSGroup -> Map WorkspaceId WSGroup
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. WSGroupStorage -> Map WorkspaceId WSGroup
unWSG

instance ExtensionClass WSGroupStorage where
  initialValue :: WSGroupStorage
initialValue = Map WorkspaceId WSGroup -> WSGroupStorage
WSG forall k a. Map k a
M.empty
  extensionType :: WSGroupStorage -> StateExtension
extensionType = forall a. (Read a, Show a, ExtensionClass a) => a -> StateExtension
PersistentExtension

-- | Add a new workspace group of the given name, mapping to an
--   explicitly specified association between screen IDs and workspace
--   names.  This function could be useful for, say, creating some
--   standard workspace groups in your startup hook.
addRawWSGroup :: WSGroupId -> [(ScreenId, WorkspaceId)] -> X ()
addRawWSGroup :: WorkspaceId -> WSGroup -> X ()
addRawWSGroup WorkspaceId
name = forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map WorkspaceId WSGroup -> Map WorkspaceId WSGroup)
-> WSGroupStorage -> WSGroupStorage
withWSG forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert WorkspaceId
name

-- | Add a new workspace group with the given name.
addWSGroup :: WSGroupId -> [WorkspaceId] -> X ()
addWSGroup :: WorkspaceId -> [WorkspaceId] -> X ()
addWSGroup WorkspaceId
name [WorkspaceId]
wids = forall a. (WindowSet -> X a) -> X a
withWindowSet forall a b. (a -> b) -> a -> b
$ \WindowSet
w -> do
  let wss :: [(WorkspaceId, ScreenId)]
wss  = forall a b. (a -> b) -> [a] -> [b]
map ((forall i l a. Workspace i l a -> i
W.tag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace) forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall i l a sid sd. Screen i l a sid sd -> sid
W.screen) forall a b. (a -> b) -> a -> b
$ forall i l a s sd. StackSet i l a s sd -> [Screen i l a s sd]
W.screens WindowSet
w
      wmap :: Maybe WSGroup
wmap = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {m :: * -> *} {a} {b}. Monad m => (m a, b) -> m (a, b)
strength forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [(WorkspaceId, ScreenId)]
wss forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. a -> a
id)) [WorkspaceId]
wids
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe WSGroup
wmap (WorkspaceId -> WSGroup -> X ()
addRawWSGroup WorkspaceId
name)
 where strength :: (m a, b) -> m (a, b)
strength (m a
ma, b
b) = m a
ma forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,b
b)

-- | Give a name to the current workspace group.
addCurrentWSGroup :: WSGroupId -> X ()
addCurrentWSGroup :: WorkspaceId -> X ()
addCurrentWSGroup WorkspaceId
name = forall a. (WindowSet -> X a) -> X a
withWindowSet forall a b. (a -> b) -> a -> b
$ \WindowSet
w ->
  WorkspaceId -> [WorkspaceId] -> X ()
addWSGroup WorkspaceId
name forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall i l a. Workspace i l a -> i
W.tag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace) (forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current WindowSet
w forall a. a -> [a] -> [a]
: forall i l a s sd. StackSet i l a s sd -> [Screen i l a s sd]
W.visible WindowSet
w)

-- | Delete the named workspace group from the list of workspace
--   groups.  Note that this has no effect on the workspaces involved;
--   it simply forgets the given name.
forgetWSGroup :: WSGroupId -> X ()
forgetWSGroup :: WorkspaceId -> X ()
forgetWSGroup = forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map WorkspaceId WSGroup -> Map WorkspaceId WSGroup)
-> WSGroupStorage -> WSGroupStorage
withWSG forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Map k a
M.delete

-- | View the workspace group with the given name.
viewWSGroup :: WSGroupId -> X ()
viewWSGroup :: WorkspaceId -> X ()
viewWSGroup = (WorkspaceId -> X ()) -> WorkspaceId -> X ()
viewGroup ((WindowSet -> WindowSet) -> X ()
windows forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s i l a sd.
(Eq s, Eq i) =>
i -> StackSet i l a s sd -> StackSet i l a s sd
W.greedyView)

-- | Internal function for viewing a group.
viewGroup :: (WorkspaceId -> X ()) -> WSGroupId -> X ()
viewGroup :: (WorkspaceId -> X ()) -> WorkspaceId -> X ()
viewGroup WorkspaceId -> X ()
fview WorkspaceId
name = do
  WSG Map WorkspaceId WSGroup
m <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup WorkspaceId
name Map WorkspaceId WSGroup
m) forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((WorkspaceId -> X ()) -> ScreenId -> WorkspaceId -> X ()
viewWS WorkspaceId -> X ()
fview))

-- | View the given workspace on the given screen, using the provided function.
viewWS :: (WorkspaceId -> X ())  -> ScreenId -> WorkspaceId -> X ()
viewWS :: (WorkspaceId -> X ()) -> ScreenId -> WorkspaceId -> X ()
viewWS WorkspaceId -> X ()
fview ScreenId
sid WorkspaceId
wid = do
  Maybe WorkspaceId
mw <- ScreenId -> X (Maybe WorkspaceId)
findScreenWS ScreenId
sid
  case Maybe WorkspaceId
mw of
    Just WorkspaceId
w -> do
      (WindowSet -> WindowSet) -> X ()
windows forall a b. (a -> b) -> a -> b
$ forall s i l a sd.
(Eq s, Eq i) =>
i -> StackSet i l a s sd -> StackSet i l a s sd
W.view WorkspaceId
w
      WorkspaceId -> X ()
fview WorkspaceId
wid
    Maybe WorkspaceId
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Find the workspace which is currently on the given screen.
findScreenWS :: ScreenId -> X (Maybe WorkspaceId)
findScreenWS :: ScreenId -> X (Maybe WorkspaceId)
findScreenWS ScreenId
sid = forall a. (WindowSet -> X a) -> X a
withWindowSet forall a b. (a -> b) -> a -> b
$
  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall i l a. Workspace i l a -> i
W.tag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
==ScreenId
sid) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. Screen i l a sid sd -> sid
W.screen) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a s sd. StackSet i l a s sd -> [Screen i l a s sd]
W.screens

newtype WSGPrompt = WSGPrompt String

instance XPrompt WSGPrompt where
  showXPrompt :: WSGPrompt -> WorkspaceId
showXPrompt (WSGPrompt WorkspaceId
s) = WorkspaceId
s

-- | Prompt for a workspace group to view.
promptWSGroupView :: XPConfig -> String -> X ()
promptWSGroupView :: XPConfig -> WorkspaceId -> X ()
promptWSGroupView = (WorkspaceId -> X ()) -> XPConfig -> WorkspaceId -> X ()
promptGroupView WorkspaceId -> X ()
viewWSGroup

-- | Internal function for making a prompt to view a workspace group
promptGroupView :: (WSGroupId -> X ()) -> XPConfig -> String -> X ()
promptGroupView :: (WorkspaceId -> X ()) -> XPConfig -> WorkspaceId -> X ()
promptGroupView WorkspaceId -> X ()
fview XPConfig
xp WorkspaceId
s = do
  [WorkspaceId]
gs <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall k a. Map k a -> [k]
M.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. WSGroupStorage -> Map WorkspaceId WSGroup
unWSG) forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
  forall p.
XPrompt p =>
p -> XPConfig -> ComplFunction -> (WorkspaceId -> X ()) -> X ()
mkXPrompt (WorkspaceId -> WSGPrompt
WSGPrompt WorkspaceId
s) XPConfig
xp (XPConfig -> [WorkspaceId] -> ComplFunction
mkComplFunFromList' XPConfig
xp [WorkspaceId]
gs) WorkspaceId -> X ()
fview

-- | Prompt for a name for the current workspace group.
promptWSGroupAdd :: XPConfig -> String -> X ()
promptWSGroupAdd :: XPConfig -> WorkspaceId -> X ()
promptWSGroupAdd XPConfig
xp WorkspaceId
s =
  forall p.
XPrompt p =>
p -> XPConfig -> ComplFunction -> (WorkspaceId -> X ()) -> X ()
mkXPrompt (WorkspaceId -> WSGPrompt
WSGPrompt WorkspaceId
s) XPConfig
xp (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return []) WorkspaceId -> X ()
addCurrentWSGroup

-- | Prompt for a workspace group to forget.
promptWSGroupForget :: XPConfig -> String -> X ()
promptWSGroupForget :: XPConfig -> WorkspaceId -> X ()
promptWSGroupForget XPConfig
xp WorkspaceId
s = do
  [WorkspaceId]
gs <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall k a. Map k a -> [k]
M.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. WSGroupStorage -> Map WorkspaceId WSGroup
unWSG) forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
  forall p.
XPrompt p =>
p -> XPConfig -> ComplFunction -> (WorkspaceId -> X ()) -> X ()
mkXPrompt (WorkspaceId -> WSGPrompt
WSGPrompt WorkspaceId
s) XPConfig
xp (XPConfig -> [WorkspaceId] -> ComplFunction
mkComplFunFromList' XPConfig
xp [WorkspaceId]
gs) WorkspaceId -> X ()
forgetWSGroup

-- $topics
-- You can use this module with "XMonad.Actions.TopicSpace" — just replace
-- 'promptWSGroupView' with 'promptTopicGroupView':
--
-- >    , ("M-y n", promptWSGroupAdd myXPConfig "Name this group: ")
-- >    , ("M-y g", promptTopicGroupView myTopicConfig myXPConfig "Go to group: ")
-- >    , ("M-y d", promptWSGroupForget myXPConfig "Forget group: ")
--
-- It's also a good idea to replace 'spawn' with
-- 'XMonad.Actions.SpawnOn.spawnOn' or 'XMonad.Actions.SpawnOn.spawnHere' in
-- your topic actions, so everything is spawned where it should be.

-- | Prompt for a workspace group to view, treating the workspaces as topics.
promptTopicGroupView :: TopicConfig -> XPConfig -> String -> X ()
promptTopicGroupView :: TopicConfig -> XPConfig -> WorkspaceId -> X ()
promptTopicGroupView = (WorkspaceId -> X ()) -> XPConfig -> WorkspaceId -> X ()
promptGroupView forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopicConfig -> WorkspaceId -> X ()
viewTopicGroup

-- | View the workspace group with the given name, treating the workspaces as
-- topics.
viewTopicGroup :: TopicConfig -> WSGroupId -> X ()
viewTopicGroup :: TopicConfig -> WorkspaceId -> X ()
viewTopicGroup = (WorkspaceId -> X ()) -> WorkspaceId -> X ()
viewGroup forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopicConfig -> WorkspaceId -> X ()
switchTopic