xmonad-contrib/XMonad/Actions/DynamicWorkspaceOrder.hs

{-# LANGUAGE DeriveDataTypeable #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Actions.DynamicWorkspaceOrder
-- 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.DynamicLog".
--
-----------------------------------------------------------------------------

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

      getWsCompareByOrder
    , getSortByOrder
    , swapWith

    , moveTo
    , moveToGreedy
    , shiftTo

    , 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 Data.Maybe (fromJust, fromMaybe)
import Data.Ord (comparing)

-- $usage
-- You can use this module by importing it into your ~\/.xmonad\/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.DynamicLog", use 'getSortByOrder' in your
-- 'XMonad.Hooks.DynamicLog.ppSort' field, for example:
--
-- >   ... dynamicLogWithPP $ 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.
data WSOrderStorage = WSO { unWSO :: Maybe (M.Map WorkspaceId Int) }
  deriving (Typeable, Read, Show)

instance ExtensionClass WSOrderStorage where
  initialValue = WSO Nothing
  extensionType = PersistentExtension

-- | Lift a Map function to a function on WSOrderStorage.
withWSO :: (M.Map WorkspaceId Int -> M.Map WorkspaceId Int)
           -> (WSOrderStorage -> WSOrderStorage)
withWSO f = WSO . fmap f . unWSO

-- | Update the ordering storage: initialize if it doesn't yet exist;
-- add newly created workspaces at the end as necessary.
updateOrder :: X ()
updateOrder = do
  WSO mm <- XS.get
  case mm of
    Nothing -> do
      -- initialize using ordering of workspaces from the user's config
      ws <- asks (workspaces . config)
      XS.put . WSO . Just . M.fromList $ zip ws [0..]
    Just m -> do
      -- check for new workspaces and add them at the end
      curWs <- gets (S.fromList . map W.tag . W.workspaces . windowset)
      let mappedWs  = M.keysSet m
          newWs     = curWs `S.difference` mappedWs
          nextIndex = 1 + maximum (-1 : M.elems m)
          newWsIxs  = zip (S.toAscList newWs) [nextIndex..]
      XS.modify . withWSO . M.union . M.fromList $ newWsIxs

-- | A comparison function which orders workspaces according to the
-- stored dynamic ordering.
getWsCompareByOrder :: X WorkspaceCompare
getWsCompareByOrder = do
  updateOrder
  -- after the call to updateOrder we are guaranteed that the dynamic
  -- workspace order is initialized and contains all existing
  -- workspaces.
  WSO (Just m) <- XS.get
  return $ comparing (fromMaybe 1000 . flip M.lookup m)

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

-- | Swap the current workspace with another workspace in the stored
-- dynamic order.
swapWith :: Direction1D -> WSType -> X ()
swapWith dir which = findWorkspace getSortByOrder dir which 1 >>= swapWithCurrent

-- | Swap the given workspace with the current one.
swapWithCurrent :: WorkspaceId -> X ()
swapWithCurrent w = do
  cur <- gets (W.currentTag . windowset)
  swapOrder w cur

-- | Swap the two given workspaces in the dynamic order.
swapOrder :: WorkspaceId -> WorkspaceId -> X ()
swapOrder w1 w2 = do
  io $ print (w1,w2)
  WSO (Just m) <- XS.get
  let [i1,i2] = map (fromJust . flip M.lookup m) [w1,w2]
  XS.modify (withWSO (M.insert w1 i2 . M.insert w2 i1))
  windows id  -- force a status bar update

-- | 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 dir t = doTo dir t getSortByOrder (windows . W.view)

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

-- | 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 job wnum = do
  sort <- getSortByOrder
  ws <- gets (map W.tag . sort . W.workspaces . windowset)
  case drop wnum ws of
    (w:_) -> windows $ job w
    []    -> return ()