-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Hooks.WorkspaceHistory
-- Description :  Keep track of workspace viewing order.
-- Copyright   :  (c) 2013 Dmitri Iouchtchenko
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  Dmitri Iouchtchenko <johnnyspoon@gmail.com>
-- Stability   :  unstable
-- Portability :  unportable
--
-- Keeps track of workspace viewing order.
--
-----------------------------------------------------------------------------

module XMonad.Hooks.WorkspaceHistory (
      -- * Usage
      -- $usage
      -- * Hooking
    workspaceHistoryHook
  , workspaceHistoryHookExclude
      -- * Querying
  , workspaceHistory
  , workspaceHistoryByScreen
  , workspaceHistoryWithScreen
    -- * Handling edits
  , workspaceHistoryTransaction
  , workspaceHistoryModify
  ) where

import           Control.Applicative
import           Prelude

import XMonad
import XMonad.StackSet hiding (delete, filter, new)
import XMonad.Prelude (delete, find, foldl', groupBy, nub, sortBy)
import qualified XMonad.Util.ExtensibleState as XS

-- $usage
-- To record the order in which you view workspaces, you can use this
-- module with the following in your @~\/.xmonad\/xmonad.hs@:
--
-- > import XMonad.Hooks.WorkspaceHistory (workspaceHistoryHook)
--
-- Then add the hook to your 'logHook':
--
-- >  main = xmonad $ def
-- >      { ...
-- >      , logHook = ... >> workspaceHistoryHook >> ...
-- >      , ...
-- >      }
--
-- If you want to completely exclude certain workspaces from entering
-- the history, you can use 'workspaceHistoryHookExclude' instead.  For
-- example, to ignore the named scratchpad workspace:
--
-- > import XMonad.Util.NamedScratchpad (scratchpadWorkspaceTag)
-- > ...
-- > , logHook = ... >> workspaceHistoryHookExclude [scratchpadWorkspaceTag] >> ...
--
-- To make use of the collected data, a query function is provided.

newtype WorkspaceHistory = WorkspaceHistory
  { WorkspaceHistory -> [(ScreenId, WorkspaceId)]
history :: [(ScreenId, WorkspaceId)] -- ^ Workspace Screens in
                                         -- reverse-chronological order.
  } deriving (ReadPrec [WorkspaceHistory]
ReadPrec WorkspaceHistory
Int -> ReadS WorkspaceHistory
ReadS [WorkspaceHistory]
(Int -> ReadS WorkspaceHistory)
-> ReadS [WorkspaceHistory]
-> ReadPrec WorkspaceHistory
-> ReadPrec [WorkspaceHistory]
-> Read WorkspaceHistory
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [WorkspaceHistory]
$creadListPrec :: ReadPrec [WorkspaceHistory]
readPrec :: ReadPrec WorkspaceHistory
$creadPrec :: ReadPrec WorkspaceHistory
readList :: ReadS [WorkspaceHistory]
$creadList :: ReadS [WorkspaceHistory]
readsPrec :: Int -> ReadS WorkspaceHistory
$creadsPrec :: Int -> ReadS WorkspaceHistory
Read, Int -> WorkspaceHistory -> ShowS
[WorkspaceHistory] -> ShowS
WorkspaceHistory -> WorkspaceId
(Int -> WorkspaceHistory -> ShowS)
-> (WorkspaceHistory -> WorkspaceId)
-> ([WorkspaceHistory] -> ShowS)
-> Show WorkspaceHistory
forall a.
(Int -> a -> ShowS)
-> (a -> WorkspaceId) -> ([a] -> ShowS) -> Show a
showList :: [WorkspaceHistory] -> ShowS
$cshowList :: [WorkspaceHistory] -> ShowS
show :: WorkspaceHistory -> WorkspaceId
$cshow :: WorkspaceHistory -> WorkspaceId
showsPrec :: Int -> WorkspaceHistory -> ShowS
$cshowsPrec :: Int -> WorkspaceHistory -> ShowS
Show)

instance ExtensionClass WorkspaceHistory where
    initialValue :: WorkspaceHistory
initialValue = [(ScreenId, WorkspaceId)] -> WorkspaceHistory
WorkspaceHistory []
    extensionType :: WorkspaceHistory -> StateExtension
extensionType = WorkspaceHistory -> StateExtension
forall a. (Read a, Show a, ExtensionClass a) => a -> StateExtension
PersistentExtension

-- | A 'logHook' that keeps track of the order in which workspaces have
-- been viewed.
workspaceHistoryHook :: X ()
workspaceHistoryHook :: X ()
workspaceHistoryHook = (XState -> WindowSet) -> X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset X WindowSet -> (WindowSet -> X ()) -> X ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((WorkspaceHistory -> WorkspaceHistory) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify ((WorkspaceHistory -> WorkspaceHistory) -> X ())
-> (WindowSet -> WorkspaceHistory -> WorkspaceHistory)
-> WindowSet
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet -> WorkspaceHistory -> WorkspaceHistory
updateLastActiveOnEachScreen)

-- | Like 'workspaceHistoryHook', but with the ability to exclude
-- certain workspaces.
workspaceHistoryHookExclude :: [WorkspaceId] -> X ()
workspaceHistoryHookExclude :: [WorkspaceId] -> X ()
workspaceHistoryHookExclude [WorkspaceId]
ws =
  (XState -> WindowSet) -> X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset X WindowSet -> (WindowSet -> X ()) -> X ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (WorkspaceHistory -> WorkspaceHistory) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify ((WorkspaceHistory -> WorkspaceHistory) -> X ())
-> (WindowSet -> WorkspaceHistory -> WorkspaceHistory)
-> WindowSet
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [WorkspaceId] -> WindowSet -> WorkspaceHistory -> WorkspaceHistory
updateLastActiveOnEachScreenExclude [WorkspaceId]
ws

workspaceHistoryWithScreen :: X [(ScreenId, WorkspaceId)]
workspaceHistoryWithScreen :: X [(ScreenId, WorkspaceId)]
workspaceHistoryWithScreen = (WorkspaceHistory -> [(ScreenId, WorkspaceId)])
-> X [(ScreenId, WorkspaceId)]
forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets WorkspaceHistory -> [(ScreenId, WorkspaceId)]
history

workspaceHistoryByScreen :: X [(ScreenId, [WorkspaceId])]
workspaceHistoryByScreen :: X [(ScreenId, [WorkspaceId])]
workspaceHistoryByScreen =
  ([(ScreenId, WorkspaceId)] -> (ScreenId, [WorkspaceId]))
-> [[(ScreenId, WorkspaceId)]] -> [(ScreenId, [WorkspaceId])]
forall a b. (a -> b) -> [a] -> [b]
map (\[(ScreenId, WorkspaceId)]
wss -> ((ScreenId, WorkspaceId) -> ScreenId
forall a b. (a, b) -> a
fst ((ScreenId, WorkspaceId) -> ScreenId)
-> (ScreenId, WorkspaceId) -> ScreenId
forall a b. (a -> b) -> a -> b
$ [(ScreenId, WorkspaceId)] -> (ScreenId, WorkspaceId)
forall a. [a] -> a
head [(ScreenId, WorkspaceId)]
wss, ((ScreenId, WorkspaceId) -> WorkspaceId)
-> [(ScreenId, WorkspaceId)] -> [WorkspaceId]
forall a b. (a -> b) -> [a] -> [b]
map (ScreenId, WorkspaceId) -> WorkspaceId
forall a b. (a, b) -> b
snd [(ScreenId, WorkspaceId)]
wss)) ([[(ScreenId, WorkspaceId)]] -> [(ScreenId, [WorkspaceId])])
-> ([(ScreenId, WorkspaceId)] -> [[(ScreenId, WorkspaceId)]])
-> [(ScreenId, WorkspaceId)]
-> [(ScreenId, [WorkspaceId])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  ((ScreenId, WorkspaceId) -> (ScreenId, WorkspaceId) -> Bool)
-> [(ScreenId, WorkspaceId)] -> [[(ScreenId, WorkspaceId)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\(ScreenId, WorkspaceId)
a (ScreenId, WorkspaceId)
b -> (ScreenId, WorkspaceId) -> ScreenId
forall a b. (a, b) -> a
fst (ScreenId, WorkspaceId)
a ScreenId -> ScreenId -> Bool
forall a. Eq a => a -> a -> Bool
== (ScreenId, WorkspaceId) -> ScreenId
forall a b. (a, b) -> a
fst (ScreenId, WorkspaceId)
b) ([(ScreenId, WorkspaceId)] -> [[(ScreenId, WorkspaceId)]])
-> ([(ScreenId, WorkspaceId)] -> [(ScreenId, WorkspaceId)])
-> [(ScreenId, WorkspaceId)]
-> [[(ScreenId, WorkspaceId)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  ((ScreenId, WorkspaceId) -> (ScreenId, WorkspaceId) -> Ordering)
-> [(ScreenId, WorkspaceId)] -> [(ScreenId, WorkspaceId)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(ScreenId, WorkspaceId)
a (ScreenId, WorkspaceId)
b -> ScreenId -> ScreenId -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((ScreenId, WorkspaceId) -> ScreenId
forall a b. (a, b) -> a
fst (ScreenId, WorkspaceId)
a) (ScreenId -> Ordering) -> ScreenId -> Ordering
forall a b. (a -> b) -> a -> b
$ (ScreenId, WorkspaceId) -> ScreenId
forall a b. (a, b) -> a
fst (ScreenId, WorkspaceId)
b)([(ScreenId, WorkspaceId)] -> [(ScreenId, [WorkspaceId])])
-> X [(ScreenId, WorkspaceId)] -> X [(ScreenId, [WorkspaceId])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  X [(ScreenId, WorkspaceId)]
workspaceHistoryWithScreen

-- | A list of workspace tags in the order they have been viewed, with the
-- most recent first. No duplicates are present, but not all workspaces are
-- guaranteed to appear, and there may be workspaces that no longer exist.
workspaceHistory :: X [WorkspaceId]
workspaceHistory :: X [WorkspaceId]
workspaceHistory = [WorkspaceId] -> [WorkspaceId]
forall a. Eq a => [a] -> [a]
nub ([WorkspaceId] -> [WorkspaceId])
-> ([(ScreenId, WorkspaceId)] -> [WorkspaceId])
-> [(ScreenId, WorkspaceId)]
-> [WorkspaceId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ScreenId, WorkspaceId) -> WorkspaceId)
-> [(ScreenId, WorkspaceId)] -> [WorkspaceId]
forall a b. (a -> b) -> [a] -> [b]
map (ScreenId, WorkspaceId) -> WorkspaceId
forall a b. (a, b) -> b
snd ([(ScreenId, WorkspaceId)] -> [WorkspaceId])
-> X [(ScreenId, WorkspaceId)] -> X [WorkspaceId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (WorkspaceHistory -> [(ScreenId, WorkspaceId)])
-> X [(ScreenId, WorkspaceId)]
forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets WorkspaceHistory -> [(ScreenId, WorkspaceId)]
history

workspaceHistoryTransaction :: X () -> X ()
workspaceHistoryTransaction :: X () -> X ()
workspaceHistoryTransaction X ()
action = do
  [(ScreenId, WorkspaceId)]
startingHistory <- (WorkspaceHistory -> [(ScreenId, WorkspaceId)])
-> X [(ScreenId, WorkspaceId)]
forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets WorkspaceHistory -> [(ScreenId, WorkspaceId)]
history
  X ()
action
  WorkspaceHistory
new <- (WindowSet -> WorkspaceHistory -> WorkspaceHistory)
-> WorkspaceHistory -> WindowSet -> WorkspaceHistory
forall a b c. (a -> b -> c) -> b -> a -> c
flip WindowSet -> WorkspaceHistory -> WorkspaceHistory
updateLastActiveOnEachScreen ([(ScreenId, WorkspaceId)] -> WorkspaceHistory
WorkspaceHistory [(ScreenId, WorkspaceId)]
startingHistory) (WindowSet -> WorkspaceHistory)
-> X WindowSet -> X WorkspaceHistory
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (XState -> WindowSet) -> X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
  WorkspaceHistory -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put WorkspaceHistory
new

-- | Update the last visible workspace on each monitor if needed
-- already there, or move it to the front if it is.
updateLastActiveOnEachScreen :: WindowSet -> WorkspaceHistory -> WorkspaceHistory
updateLastActiveOnEachScreen :: WindowSet -> WorkspaceHistory -> WorkspaceHistory
updateLastActiveOnEachScreen = [WorkspaceId] -> WindowSet -> WorkspaceHistory -> WorkspaceHistory
updateLastActiveOnEachScreenExclude []

-- | Like 'updateLastActiveOnEachScreen', but with the ability to
-- exclude certain workspaces.
updateLastActiveOnEachScreenExclude :: [WorkspaceId] -> WindowSet -> WorkspaceHistory -> WorkspaceHistory
updateLastActiveOnEachScreenExclude :: [WorkspaceId] -> WindowSet -> WorkspaceHistory -> WorkspaceHistory
updateLastActiveOnEachScreenExclude [WorkspaceId]
ws StackSet {current :: forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
current = Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
cur, visible :: forall i l a sid sd. StackSet i l a sid sd -> [Screen i l a sid sd]
visible = [Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail]
vis} WorkspaceHistory
wh =
  WorkspaceHistory :: [(ScreenId, WorkspaceId)] -> WorkspaceHistory
WorkspaceHistory { history :: [(ScreenId, WorkspaceId)]
history = Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> [(ScreenId, WorkspaceId)] -> [(ScreenId, WorkspaceId)]
forall sid l a sd.
Eq sid =>
Screen WorkspaceId l a sid sd
-> [(sid, WorkspaceId)] -> [(sid, WorkspaceId)]
doUpdate Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
cur ([(ScreenId, WorkspaceId)] -> [(ScreenId, WorkspaceId)])
-> [(ScreenId, WorkspaceId)] -> [(ScreenId, WorkspaceId)]
forall a b. (a -> b) -> a -> b
$ ([(ScreenId, WorkspaceId)]
 -> Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
 -> [(ScreenId, WorkspaceId)])
-> [(ScreenId, WorkspaceId)]
-> [Screen
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail]
-> [(ScreenId, WorkspaceId)]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [(ScreenId, WorkspaceId)]
-> Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
-> [(ScreenId, WorkspaceId)]
forall sid l a sd.
Eq sid =>
[(sid, WorkspaceId)]
-> Screen WorkspaceId l a sid sd -> [(sid, WorkspaceId)]
updateLastForScreen (WorkspaceHistory -> [(ScreenId, WorkspaceId)]
history WorkspaceHistory
wh) ([Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail]
 -> [(ScreenId, WorkspaceId)])
-> [Screen
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail]
-> [(ScreenId, WorkspaceId)]
forall a b. (a -> b) -> a -> b
$ [Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail]
vis [Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail]
-> [Screen
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail]
-> [Screen
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail]
forall a. [a] -> [a] -> [a]
++ [Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
cur] }
  where
    firstOnScreen :: a -> t (a, b) -> Maybe (a, b)
firstOnScreen a
sid = ((a, b) -> Bool) -> t (a, b) -> Maybe (a, b)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
sid) (a -> Bool) -> ((a, b) -> a) -> (a, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> a
forall a b. (a, b) -> a
fst)
    doUpdate :: Screen WorkspaceId l a sid sd
-> [(sid, WorkspaceId)] -> [(sid, WorkspaceId)]
doUpdate Screen {workspace :: forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
workspace = Workspace { tag :: forall i l a. Workspace i l a -> i
tag = WorkspaceId
wid }, screen :: forall i l a sid sd. Screen i l a sid sd -> sid
screen = sid
sid} [(sid, WorkspaceId)]
curr =
      let newEntry :: (sid, WorkspaceId)
newEntry = (sid
sid, WorkspaceId
wid)
       in if WorkspaceId
wid WorkspaceId -> [WorkspaceId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [WorkspaceId]
ws then [(sid, WorkspaceId)]
curr else (sid, WorkspaceId)
newEntry (sid, WorkspaceId) -> [(sid, WorkspaceId)] -> [(sid, WorkspaceId)]
forall a. a -> [a] -> [a]
: (sid, WorkspaceId) -> [(sid, WorkspaceId)] -> [(sid, WorkspaceId)]
forall a. Eq a => a -> [a] -> [a]
delete (sid, WorkspaceId)
newEntry [(sid, WorkspaceId)]
curr
    updateLastForScreen :: [(sid, WorkspaceId)]
-> Screen WorkspaceId l a sid sd -> [(sid, WorkspaceId)]
updateLastForScreen [(sid, WorkspaceId)]
curr Screen {workspace :: forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
workspace = Workspace { tag :: forall i l a. Workspace i l a -> i
tag = WorkspaceId
wid }, screen :: forall i l a sid sd. Screen i l a sid sd -> sid
screen = sid
sid} =
      let newEntry :: (sid, WorkspaceId)
newEntry = (sid
sid, WorkspaceId
wid)
          alreadyCurrent :: Bool
alreadyCurrent = (sid, WorkspaceId) -> Maybe (sid, WorkspaceId)
forall a. a -> Maybe a
Just (sid, WorkspaceId)
newEntry Maybe (sid, WorkspaceId) -> Maybe (sid, WorkspaceId) -> Bool
forall a. Eq a => a -> a -> Bool
== sid -> [(sid, WorkspaceId)] -> Maybe (sid, WorkspaceId)
forall (t :: * -> *) a b.
(Foldable t, Eq a) =>
a -> t (a, b) -> Maybe (a, b)
firstOnScreen sid
sid [(sid, WorkspaceId)]
curr
      in if Bool
alreadyCurrent Bool -> Bool -> Bool
|| WorkspaceId
wid WorkspaceId -> [WorkspaceId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [WorkspaceId]
ws then [(sid, WorkspaceId)]
curr else (sid, WorkspaceId)
newEntry (sid, WorkspaceId) -> [(sid, WorkspaceId)] -> [(sid, WorkspaceId)]
forall a. a -> [a] -> [a]
: (sid, WorkspaceId) -> [(sid, WorkspaceId)] -> [(sid, WorkspaceId)]
forall a. Eq a => a -> [a] -> [a]
delete (sid, WorkspaceId)
newEntry [(sid, WorkspaceId)]
curr

-- | Modify a the workspace history with a given pure function.
workspaceHistoryModify :: ([(ScreenId, WorkspaceId)] -> [(ScreenId, WorkspaceId)]) -> X ()
workspaceHistoryModify :: ([(ScreenId, WorkspaceId)] -> [(ScreenId, WorkspaceId)]) -> X ()
workspaceHistoryModify [(ScreenId, WorkspaceId)] -> [(ScreenId, WorkspaceId)]
action = (WorkspaceHistory -> WorkspaceHistory) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify ((WorkspaceHistory -> WorkspaceHistory) -> X ())
-> (WorkspaceHistory -> WorkspaceHistory) -> X ()
forall a b. (a -> b) -> a -> b
$ [(ScreenId, WorkspaceId)] -> WorkspaceHistory
WorkspaceHistory ([(ScreenId, WorkspaceId)] -> WorkspaceHistory)
-> (WorkspaceHistory -> [(ScreenId, WorkspaceId)])
-> WorkspaceHistory
-> WorkspaceHistory
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ScreenId, WorkspaceId)] -> [(ScreenId, WorkspaceId)]
action ([(ScreenId, WorkspaceId)] -> [(ScreenId, WorkspaceId)])
-> (WorkspaceHistory -> [(ScreenId, WorkspaceId)])
-> WorkspaceHistory
-> [(ScreenId, WorkspaceId)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WorkspaceHistory -> [(ScreenId, WorkspaceId)]
history