-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Actions.DynamicWorkspaceOrder
-- Description :  Remember a dynamically updateable ordering on workspaces.
-- Copyright   :  (c) Brent Yorgey 2009
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  <byorgey@gmail.com>
-- Stability   :  experimental
-- Portability :  unportable
--
-- Remember a dynamically updateable ordering on workspaces, together
-- with tools for using this ordering with "XMonad.Actions.CycleWS"
-- and "XMonad.Hooks.StatusBar.PP".
--
-----------------------------------------------------------------------------

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

      getWsCompareByOrder
    , getSortByOrder
    , swapWith
    , swapWithCurrent
    , swapOrder
    , updateName
    , removeName

    , moveTo
    , moveToGreedy
    , shiftTo

    , withNthWorkspace'
    , withNthWorkspace

    ) where

import XMonad
import qualified XMonad.StackSet as W
import qualified XMonad.Util.ExtensibleState as XS

import XMonad.Util.WorkspaceCompare (WorkspaceCompare, WorkspaceSort, mkWsSort)
import XMonad.Actions.CycleWS (findWorkspace, WSType(..), Direction1D(..), doTo)

import qualified Data.Map as M
import qualified Data.Set as S
import XMonad.Prelude (fromJust, fromMaybe)
import Data.Ord (comparing)

-- $usage
-- You can use this module by importing it into your @xmonad.hs@ file:
--
-- > import qualified XMonad.Actions.DynamicWorkspaceOrder as DO
--
-- Then add keybindings to swap the order of workspaces (these
-- examples use "XMonad.Util.EZConfig" emacs-style keybindings):
--
-- >        , ("M-C-<R>",   DO.swapWith Next NonEmptyWS)
-- >        , ("M-C-<L>",   DO.swapWith Prev NonEmptyWS)
--
-- See "XMonad.Actions.CycleWS" for information on the possible
-- arguments to 'swapWith'.
--
-- However, by itself this will do nothing; 'swapWith' does not change
-- the actual workspaces in any way.  It simply keeps track of an
-- auxiliary ordering on workspaces.  Anything which cares about the
-- order of workspaces must be updated to use the auxiliary ordering.
--
-- To change the order in which workspaces are displayed by
-- "XMonad.Hooks.StatusBar.PP", use 'getSortByOrder' in your
-- 'XMonad.Hooks.StatusBar.PP.ppSort' field, for example:
--
-- >   myPP = ... byorgeyPP {
-- >     ...
-- >     , ppSort = DO.getSortByOrder
-- >     ...
-- >   }
--
-- To use workspace cycling commands like those from
-- "XMonad.Actions.CycleWS", use the versions of 'moveTo',
-- 'moveToGreedy', and 'shiftTo' exported by this module.  For example:
--
-- >     , ("M-S-<R>",   DO.shiftTo Next HiddenNonEmptyWS)
-- >     , ("M-S-<L>",   DO.shiftTo Prev HiddenNonEmptyWS)
-- >     , ("M-<R>",     DO.moveTo Next HiddenNonEmptyWS)
-- >     , ("M-<L>",     DO.moveTo Prev HiddenNonEmptyWS)
--
-- For slight variations on these, use the source for examples and
-- tweak as desired.

-- | Extensible state storage for the workspace order.
newtype WSOrderStorage = WSO { WSOrderStorage -> Maybe (Map WorkspaceId Int)
unWSO :: Maybe (M.Map WorkspaceId Int) }
  deriving (ReadPrec [WSOrderStorage]
ReadPrec WSOrderStorage
Int -> ReadS WSOrderStorage
ReadS [WSOrderStorage]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [WSOrderStorage]
$creadListPrec :: ReadPrec [WSOrderStorage]
readPrec :: ReadPrec WSOrderStorage
$creadPrec :: ReadPrec WSOrderStorage
readList :: ReadS [WSOrderStorage]
$creadList :: ReadS [WSOrderStorage]
readsPrec :: Int -> ReadS WSOrderStorage
$creadsPrec :: Int -> ReadS WSOrderStorage
Read, Int -> WSOrderStorage -> ShowS
[WSOrderStorage] -> ShowS
WSOrderStorage -> WorkspaceId
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
showList :: [WSOrderStorage] -> ShowS
$cshowList :: [WSOrderStorage] -> ShowS
show :: WSOrderStorage -> WorkspaceId
$cshow :: WSOrderStorage -> WorkspaceId
showsPrec :: Int -> WSOrderStorage -> ShowS
$cshowsPrec :: Int -> WSOrderStorage -> ShowS
Show)

instance ExtensionClass WSOrderStorage where
  initialValue :: WSOrderStorage
initialValue = Maybe (Map WorkspaceId Int) -> WSOrderStorage
WSO forall a. Maybe a
Nothing
  extensionType :: WSOrderStorage -> StateExtension
extensionType = forall a. (Read a, Show a, ExtensionClass a) => a -> StateExtension
PersistentExtension

-- | Lift a Map function to a function on WSOrderStorage.
withWSO :: (M.Map WorkspaceId Int -> M.Map WorkspaceId Int)
           -> (WSOrderStorage -> WSOrderStorage)
withWSO :: (Map WorkspaceId Int -> Map WorkspaceId Int)
-> WSOrderStorage -> WSOrderStorage
withWSO Map WorkspaceId Int -> Map WorkspaceId Int
f = Maybe (Map WorkspaceId Int) -> WSOrderStorage
WSO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map WorkspaceId Int -> Map WorkspaceId Int
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. WSOrderStorage -> Maybe (Map WorkspaceId Int)
unWSO

-- | Update the ordering storage: initialize if it doesn't yet exist;
-- add newly created workspaces at the end as necessary.
updateOrder :: X ()
updateOrder :: X ()
updateOrder = do
  WSO Maybe (Map WorkspaceId Int)
mm <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
  case Maybe (Map WorkspaceId Int)
mm of
    Maybe (Map WorkspaceId Int)
Nothing -> do
      -- initialize using ordering of workspaces from the user's config
      [WorkspaceId]
ws <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall (l :: * -> *). XConfig l -> [WorkspaceId]
workspaces forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config)
      forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Map WorkspaceId Int) -> WSOrderStorage
WSO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [WorkspaceId]
ws [Int
0..]
    Just Map WorkspaceId Int
m -> do
      -- check for new workspaces and add them at the end
      Set WorkspaceId
curWs <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall a. Ord a => [a] -> Set a
S.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 s sd. StackSet i l a s sd -> [Workspace i l a]
W.workspaces forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset)
      let mappedWs :: Set WorkspaceId
mappedWs  = forall k a. Map k a -> Set k
M.keysSet Map WorkspaceId Int
m
          newWs :: Set WorkspaceId
newWs     = Set WorkspaceId
curWs forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set WorkspaceId
mappedWs
          nextIndex :: Int
nextIndex = Int
1 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (-Int
1 forall a. a -> [a] -> [a]
: forall k a. Map k a -> [a]
M.elems Map WorkspaceId Int
m)
          newWsIxs :: [(WorkspaceId, Int)]
newWsIxs  = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Set a -> [a]
S.toAscList Set WorkspaceId
newWs) [Int
nextIndex..]
      forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map WorkspaceId Int -> Map WorkspaceId Int)
-> WSOrderStorage -> WSOrderStorage
withWSO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ [(WorkspaceId, Int)]
newWsIxs

-- | A comparison function which orders workspaces according to the
-- stored dynamic ordering.
getWsCompareByOrder :: X WorkspaceCompare
getWsCompareByOrder :: X WorkspaceCompare
getWsCompareByOrder = do
  X ()
updateOrder
  -- after the call to updateOrder we are guaranteed that the dynamic
  -- workspace order is initialized and contains all existing
  -- workspaces.
  WSO (Just Map WorkspaceId Int
m) <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (forall a. a -> Maybe a -> a
fromMaybe Int
1000 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map WorkspaceId Int
m)

-- | Sort workspaces according to the stored dynamic ordering.
getSortByOrder :: X WorkspaceSort
getSortByOrder :: X WorkspaceSort
getSortByOrder = X WorkspaceCompare -> X WorkspaceSort
mkWsSort X WorkspaceCompare
getWsCompareByOrder

-- | Swap the current workspace with another workspace in the stored
-- dynamic order.
swapWith :: Direction1D -> WSType -> X ()
swapWith :: Direction1D -> WSType -> X ()
swapWith Direction1D
dir WSType
which = X WorkspaceSort -> Direction1D -> WSType -> Int -> X WorkspaceId
findWorkspace X WorkspaceSort
getSortByOrder Direction1D
dir WSType
which Int
1 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WorkspaceId -> X ()
swapWithCurrent

-- | Swap the given workspace with the current one.
swapWithCurrent :: WorkspaceId -> X ()
swapWithCurrent :: WorkspaceId -> X ()
swapWithCurrent WorkspaceId
w = do
  WorkspaceId
cur <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall i l a s sd. StackSet i l a s sd -> i
W.currentTag forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset)
  WorkspaceId -> WorkspaceId -> X ()
swapOrder WorkspaceId
w WorkspaceId
cur

-- | Swap the two given workspaces in the dynamic order.
swapOrder :: WorkspaceId -> WorkspaceId -> X ()
swapOrder :: WorkspaceId -> WorkspaceId -> X ()
swapOrder WorkspaceId
w1 WorkspaceId
w2 = do
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> IO ()
print (WorkspaceId
w1,WorkspaceId
w2)
  WSO (Just Map WorkspaceId Int
m) <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
  let i1 :: Int
i1 = forall a. HasCallStack => Maybe a -> a
fromJust (WorkspaceId
w1 forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map WorkspaceId Int
m)
  let i2 :: Int
i2 = forall a. HasCallStack => Maybe a -> a
fromJust (WorkspaceId
w2 forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map WorkspaceId Int
m)
  forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify ((Map WorkspaceId Int -> Map WorkspaceId Int)
-> WSOrderStorage -> WSOrderStorage
withWSO (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert WorkspaceId
w1 Int
i2 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
w2 Int
i1))
  (WindowSet -> WindowSet) -> X ()
windows forall a. a -> a
id  -- force a status bar update

-- | Update the name of a workspace in the stored order.
updateName :: WorkspaceId -> WorkspaceId -> X ()
updateName :: WorkspaceId -> WorkspaceId -> X ()
updateName WorkspaceId
oldId WorkspaceId
newId = forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map WorkspaceId Int -> Map WorkspaceId Int)
-> WSOrderStorage -> WSOrderStorage
withWSO forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> k -> Map k a -> Map k a
changeKey WorkspaceId
oldId WorkspaceId
newId

-- | Remove a workspace from the stored order.
removeName :: WorkspaceId -> X ()
removeName :: WorkspaceId -> X ()
removeName = forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map WorkspaceId Int -> Map WorkspaceId Int)
-> WSOrderStorage -> WSOrderStorage
withWSO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Map k a
M.delete

-- | Update a key in a Map.
changeKey :: Ord k => k -> k -> M.Map k a -> M.Map k a
changeKey :: forall k a. Ord k => k -> k -> Map k a -> Map k a
changeKey k
oldKey k
newKey Map k a
oldMap =
  case forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
M.updateLookupWithKey (\k
_ a
_ -> forall a. Maybe a
Nothing) k
oldKey Map k a
oldMap of
    (Maybe a
Nothing, Map k a
_) -> Map k a
oldMap
    (Just a
val, Map k a
newMap) -> forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
newKey a
val Map k a
newMap

-- | View the next workspace of the given type in the given direction,
-- where \"next\" is determined using the dynamic workspace order.
moveTo :: Direction1D -> WSType -> X ()
moveTo :: Direction1D -> WSType -> X ()
moveTo Direction1D
dir WSType
t = Direction1D
-> WSType -> X WorkspaceSort -> (WorkspaceId -> X ()) -> X ()
doTo Direction1D
dir WSType
t X WorkspaceSort
getSortByOrder ((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.view)

-- | Same as 'moveTo', but using 'greedyView' instead of 'view'.
moveToGreedy :: Direction1D -> WSType -> X ()
moveToGreedy :: Direction1D -> WSType -> X ()
moveToGreedy Direction1D
dir WSType
t = Direction1D
-> WSType -> X WorkspaceSort -> (WorkspaceId -> X ()) -> X ()
doTo Direction1D
dir WSType
t X WorkspaceSort
getSortByOrder ((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)

-- | Shift the currently focused window to the next workspace of the
-- given type in the given direction, using the dynamic workspace order.
shiftTo :: Direction1D -> WSType -> X ()
shiftTo :: Direction1D -> WSType -> X ()
shiftTo Direction1D
dir WSType
t = Direction1D
-> WSType -> X WorkspaceSort -> (WorkspaceId -> X ()) -> X ()
doTo Direction1D
dir WSType
t X WorkspaceSort
getSortByOrder ((WindowSet -> WindowSet) -> X ()
windows forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s i l sd.
(Ord a, Eq s, Eq i) =>
i -> StackSet i l a s sd -> StackSet i l a s sd
W.shift)

-- | Do something with the nth workspace in the dynamic order after
--   transforming it.  The callback is given the workspace's tag as well
--   as the 'WindowSet' of the workspace itself.
withNthWorkspace' :: ([WorkspaceId] -> [WorkspaceId]) -> (String -> WindowSet -> WindowSet) -> Int -> X ()
withNthWorkspace' :: ([WorkspaceId] -> [WorkspaceId])
-> (WorkspaceId -> WindowSet -> WindowSet) -> Int -> X ()
withNthWorkspace' [WorkspaceId] -> [WorkspaceId]
tr WorkspaceId -> WindowSet -> WindowSet
job Int
wnum = do
  WorkspaceSort
sort <- X WorkspaceSort
getSortByOrder
  [WorkspaceId]
ws <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ([WorkspaceId] -> [WorkspaceId]
tr forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
. WorkspaceSort
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a s sd. StackSet i l a s sd -> [Workspace i l a]
W.workspaces forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset)
  case forall a. Int -> [a] -> [a]
drop Int
wnum [WorkspaceId]
ws of
    (WorkspaceId
w:[WorkspaceId]
_) -> (WindowSet -> WindowSet) -> X ()
windows forall a b. (a -> b) -> a -> b
$ WorkspaceId -> WindowSet -> WindowSet
job WorkspaceId
w
    []    -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Do something with the nth workspace in the dynamic order.  The
--   callback is given the workspace's tag as well as the 'WindowSet'
--   of the workspace itself.
withNthWorkspace :: (String -> WindowSet -> WindowSet) -> Int -> X ()
withNthWorkspace :: (WorkspaceId -> WindowSet -> WindowSet) -> Int -> X ()
withNthWorkspace = ([WorkspaceId] -> [WorkspaceId])
-> (WorkspaceId -> WindowSet -> WindowSet) -> Int -> X ()
withNthWorkspace' forall a. a -> a
id