{-# LANGUAGE DeriveDataTypeable #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Actions.TopicSpace
-- Copyright   :  (c) Nicolas Pouillard
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  Nicolas Pouillard <nicolas.pouillard@gmail.com>
-- Stability   :  unstable
-- Portability :  unportable
--
-- Turns your workspaces into a more topic oriented system.
-----------------------------------------------------------------------------

module XMonad.Actions.TopicSpace
  (
  -- * Overview
  -- $overview

  -- * Usage
  -- $usage
   Topic
  , Dir
  , TopicConfig(..)
  , def
  , defaultTopicConfig
  , getLastFocusedTopics
  , setLastFocusedTopic
  , reverseLastFocusedTopics
  , pprWindowSet
  , topicActionWithPrompt
  , topicAction
  , currentTopicAction
  , switchTopic
  , switchNthLastFocused
  , shiftNthLastFocused
  , currentTopicDir
  , checkTopicConfig
  , (>*>)
  )
where

import XMonad

import Data.List
import Data.Maybe (fromMaybe, isNothing, listToMaybe, fromJust)
import Data.Ord
import qualified Data.Map as M
import Control.Monad (liftM2,when,unless,replicateM_)
import System.IO

import qualified XMonad.StackSet as W

import XMonad.Prompt
import XMonad.Prompt.Workspace

import XMonad.Hooks.UrgencyHook
import XMonad.Hooks.DynamicLog (PP(..))
import qualified XMonad.Hooks.DynamicLog as DL

import XMonad.Util.Run (spawnPipe)
import qualified XMonad.Util.ExtensibleState as XS

-- $overview
-- This module allows to organize your workspaces on a precise topic basis.  So
-- instead of having a workspace called `work' you can setup one workspace per
-- task.  Here we call these workspaces, topics. The great thing with
-- topics is that one can attach a directory that makes sense to each
-- particular topic.  One can also attach an action which will be triggered
-- when switching to a topic that does not have any windows in it.  So you can
-- attach your mail client to the mail topic, some terminals in the right
-- directory to the xmonad topic... This package also provides a nice way to
-- display your topics in an historical way using a custom `pprWindowSet'
-- function. You can also easily switch to recent topics using this history
-- of last focused topics.

-- $usage
-- Here is an example of configuration using TopicSpace:
--
-- > -- The list of all topics/workspaces of your xmonad configuration.
-- > -- The order is important, new topics must be inserted
-- > -- at the end of the list if you want hot-restarting
-- > -- to work.
-- > myTopics :: [Topic]
-- > myTopics =
-- >   [ "dashboard" -- the first one
-- >   , "admin", "build", "cleaning", "conf", "darcs", "haskell", "irc"
-- >   , "mail", "movie", "music", "talk", "text", "tools", "web", "xmonad"
-- >   , "yi", "documents", "twitter", "pdf"
-- >   ]
-- >
-- > myTopicConfig :: TopicConfig
-- > myTopicConfig = def
-- >   { topicDirs = M.fromList $
-- >       [ ("conf", "w/conf")
-- >       , ("dashboard", "Desktop")
-- >       , ("yi", "w/dev-haskell/yi")
-- >       , ("darcs", "w/dev-haskell/darcs")
-- >       , ("haskell", "w/dev-haskell")
-- >       , ("xmonad", "w/dev-haskell/xmonad")
-- >       , ("tools", "w/tools")
-- >       , ("movie", "Movies")
-- >       , ("talk", "w/talks")
-- >       , ("music", "Music")
-- >       , ("documents", "w/documents")
-- >       , ("pdf", "w/documents")
-- >       ]
-- >   , defaultTopicAction = const $ spawnShell >*> 3
-- >   , defaultTopic = "dashboard"
-- >   , topicActions = M.fromList $
-- >       [ ("conf",       spawnShell >> spawnShellIn "wd/ertai/private")
-- >       , ("darcs",      spawnShell >*> 3)
-- >       , ("yi",         spawnShell >*> 3)
-- >       , ("haskell",    spawnShell >*> 2 >>
-- >                        spawnShellIn "wd/dev-haskell/ghc")
-- >       , ("xmonad",     spawnShellIn "wd/x11-wm/xmonad" >>
-- >                        spawnShellIn "wd/x11-wm/xmonad/contrib" >>
-- >                        spawnShellIn "wd/x11-wm/xmonad/utils" >>
-- >                        spawnShellIn ".xmonad" >>
-- >                        spawnShellIn ".xmonad")
-- >       , ("mail",       mailAction)
-- >       , ("irc",        ssh somewhere)
-- >       , ("admin",      ssh somewhere >>
-- >                        ssh nowhere)
-- >       , ("dashboard",  spawnShell)
-- >       , ("twitter",    spawnShell)
-- >       , ("web",        spawn browserCmd)
-- >       , ("movie",      spawnShell)
-- >       , ("documents",  spawnShell >*> 2 >>
-- >                        spawnShellIn "Documents" >*> 2)
-- >       , ("pdf",        spawn pdfViewerCmd)
-- >       ]
-- >   }
-- >
-- > -- extend your keybindings
-- > myKeys conf@XConfig{modMask=modm} =
-- >   [ ((modm              , xK_n     ), spawnShell) -- %! Launch terminal
-- >   , ((modm              , xK_a     ), currentTopicAction myTopicConfig)
-- >   , ((modm              , xK_g     ), promptedGoto)
-- >   , ((modm .|. shiftMask, xK_g     ), promptedShift)
-- >   {- more  keys ... -}
-- >   ]
-- >   ++
-- >   [ ((modm, k), switchNthLastFocused myTopicConfig i)
-- >   | (i, k) <- zip [1..] workspaceKeys]
-- >
-- > spawnShell :: X ()
-- > spawnShell = currentTopicDir myTopicConfig >>= spawnShellIn
-- >
-- > spawnShellIn :: Dir -> X ()
-- > spawnShellIn dir = spawn $ "urxvt '(cd ''" ++ dir ++ "'' && " ++ myShell ++ " )'"
-- >
-- > goto :: Topic -> X ()
-- > goto = switchTopic myTopicConfig
-- >
-- > promptedGoto :: X ()
-- > promptedGoto = workspacePrompt myXPConfig goto
-- >
-- > promptedShift :: X ()
-- > promptedShift = workspacePrompt myXPConfig $ windows . W.shift
-- >
-- > myConfig = do
-- >     checkTopicConfig myTopics myTopicConfig
-- >     myLogHook <- makeMyLogHook
-- >     return $ def
-- >          { borderWidth = 1 -- Width of the window border in pixels.
-- >          , workspaces = myTopics
-- >          , layoutHook = myModifiers myLayout
-- >          , manageHook = myManageHook
-- >          , logHook = myLogHook
-- >          , handleEventHook = myHandleEventHook
-- >          , terminal = myTerminal -- The preferred terminal program.
-- >          , normalBorderColor = "#3f3c6d"
-- >          , focusedBorderColor = "#4f66ff"
-- >          , XMonad.modMask = mod1Mask
-- >          , keys = myKeys
-- >          , mouseBindings = myMouseBindings
-- >          }
-- >
-- > main :: IO ()
-- > main = xmonad =<< myConfig

-- | An alias for @flip replicateM_@
(>*>) :: Monad m => m a -> Int -> m ()
>*> :: m a -> Int -> m ()
(>*>) = (Int -> m a -> m ()) -> m a -> Int -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> m a -> m ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_
infix >*>

-- | 'Topic' is just an alias for 'WorkspaceId'
type Topic = WorkspaceId

-- | 'Dir' is just an alias for 'FilePath' but should points to a directory.
type Dir = FilePath

-- | Here is the topic space configuration area.
data TopicConfig = TopicConfig { TopicConfig -> Map Topic Topic
topicDirs          :: M.Map Topic Dir
                                 -- ^ This mapping associate a directory to each topic.
                               , TopicConfig -> Map Topic (X ())
topicActions       :: M.Map Topic (X ())
                                 -- ^ This mapping associate an action to trigger when
                                 -- switching to a given topic which workspace is empty.
                               , TopicConfig -> Topic -> X ()
defaultTopicAction :: Topic -> X ()
                                 -- ^ This is the default topic action.
                               , TopicConfig -> Topic
defaultTopic       :: Topic
                                 -- ^ This is the default topic.
                               , TopicConfig -> Int
maxTopicHistory    :: Int
                                 -- ^ This setups the maximum depth of topic history, usually
                                 -- 10 is a good default since we can bind all of them using
                                 -- numeric keypad.
                               }

instance Default TopicConfig where
    def :: TopicConfig
def            = TopicConfig :: Map Topic Topic
-> Map Topic (X ())
-> (Topic -> X ())
-> Topic
-> Int
-> TopicConfig
TopicConfig { topicDirs :: Map Topic Topic
topicDirs = Map Topic Topic
forall k a. Map k a
M.empty
                                 , topicActions :: Map Topic (X ())
topicActions = Map Topic (X ())
forall k a. Map k a
M.empty
                                 , defaultTopicAction :: Topic -> X ()
defaultTopicAction = X () -> Topic -> X ()
forall a b. a -> b -> a
const (X XConf
forall r (m :: * -> *). MonadReader r m => m r
ask X XConf -> (XConf -> X ()) -> X ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Topic -> X ()
forall (m :: * -> *). MonadIO m => Topic -> m ()
spawn (Topic -> X ()) -> (XConf -> Topic) -> XConf -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConfig Layout -> Topic
forall (l :: * -> *). XConfig l -> Topic
terminal (XConfig Layout -> Topic)
-> (XConf -> XConfig Layout) -> XConf -> Topic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config)
                                 , defaultTopic :: Topic
defaultTopic = "1"
                                 , maxTopicHistory :: Int
maxTopicHistory = 10
                                 }

{-# DEPRECATED defaultTopicConfig "Use def (from Data.Default, and re-exported by XMonad.Actions.TopicSpace) instead." #-}
defaultTopicConfig :: TopicConfig
defaultTopicConfig :: TopicConfig
defaultTopicConfig = TopicConfig
forall a. Default a => a
def

newtype PrevTopics = PrevTopics { PrevTopics -> [Topic]
getPrevTopics :: [String] } deriving (ReadPrec [PrevTopics]
ReadPrec PrevTopics
Int -> ReadS PrevTopics
ReadS [PrevTopics]
(Int -> ReadS PrevTopics)
-> ReadS [PrevTopics]
-> ReadPrec PrevTopics
-> ReadPrec [PrevTopics]
-> Read PrevTopics
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PrevTopics]
$creadListPrec :: ReadPrec [PrevTopics]
readPrec :: ReadPrec PrevTopics
$creadPrec :: ReadPrec PrevTopics
readList :: ReadS [PrevTopics]
$creadList :: ReadS [PrevTopics]
readsPrec :: Int -> ReadS PrevTopics
$creadsPrec :: Int -> ReadS PrevTopics
Read,Int -> PrevTopics -> ShowS
[PrevTopics] -> ShowS
PrevTopics -> Topic
(Int -> PrevTopics -> ShowS)
-> (PrevTopics -> Topic)
-> ([PrevTopics] -> ShowS)
-> Show PrevTopics
forall a.
(Int -> a -> ShowS) -> (a -> Topic) -> ([a] -> ShowS) -> Show a
showList :: [PrevTopics] -> ShowS
$cshowList :: [PrevTopics] -> ShowS
show :: PrevTopics -> Topic
$cshow :: PrevTopics -> Topic
showsPrec :: Int -> PrevTopics -> ShowS
$cshowsPrec :: Int -> PrevTopics -> ShowS
Show,Typeable)
instance ExtensionClass PrevTopics where
    initialValue :: PrevTopics
initialValue = [Topic] -> PrevTopics
PrevTopics []
    extensionType :: PrevTopics -> StateExtension
extensionType = PrevTopics -> StateExtension
forall a. (Read a, Show a, ExtensionClass a) => a -> StateExtension
PersistentExtension

-- | Returns the list of last focused workspaces the empty list otherwise.
getLastFocusedTopics :: X [String]
getLastFocusedTopics :: X [Topic]
getLastFocusedTopics = (PrevTopics -> [Topic]) -> X [Topic]
forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets PrevTopics -> [Topic]
getPrevTopics

-- | Given a 'TopicConfig', the last focused topic, and a predicate that will
-- select topics that one want to keep, this function will set the property
-- of last focused topics.
setLastFocusedTopic :: Topic -> (Topic -> Bool) -> X ()
setLastFocusedTopic :: Topic -> (Topic -> Bool) -> X ()
setLastFocusedTopic w :: Topic
w predicate :: Topic -> Bool
predicate =
  (PrevTopics -> PrevTopics) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify ((PrevTopics -> PrevTopics) -> X ())
-> (PrevTopics -> PrevTopics) -> X ()
forall a b. (a -> b) -> a -> b
$ [Topic] -> PrevTopics
PrevTopics
    ([Topic] -> PrevTopics)
-> (PrevTopics -> [Topic]) -> PrevTopics -> PrevTopics
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Topic] -> [Topic]
forall (t :: * -> *) a. Foldable t => t a -> t a
seqList ([Topic] -> [Topic])
-> (PrevTopics -> [Topic]) -> PrevTopics -> [Topic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Topic] -> [Topic]
forall a. Eq a => [a] -> [a]
nub ([Topic] -> [Topic])
-> (PrevTopics -> [Topic]) -> PrevTopics -> [Topic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Topic
wTopic -> [Topic] -> [Topic]
forall a. a -> [a] -> [a]
:) ([Topic] -> [Topic])
-> (PrevTopics -> [Topic]) -> PrevTopics -> [Topic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Topic -> Bool) -> [Topic] -> [Topic]
forall a. (a -> Bool) -> [a] -> [a]
filter Topic -> Bool
predicate
    ([Topic] -> [Topic])
-> (PrevTopics -> [Topic]) -> PrevTopics -> [Topic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrevTopics -> [Topic]
getPrevTopics
  where seqList :: t a -> t a
seqList xs :: t a
xs = t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
xs Int -> t a -> t a
forall a b. a -> b -> b
`seq` t a
xs

-- | Reverse the list of "last focused topics"
reverseLastFocusedTopics :: X ()
reverseLastFocusedTopics :: X ()
reverseLastFocusedTopics =
  (PrevTopics -> PrevTopics) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify ((PrevTopics -> PrevTopics) -> X ())
-> (PrevTopics -> PrevTopics) -> X ()
forall a b. (a -> b) -> a -> b
$ [Topic] -> PrevTopics
PrevTopics ([Topic] -> PrevTopics)
-> (PrevTopics -> [Topic]) -> PrevTopics -> PrevTopics
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Topic] -> [Topic]
forall a. [a] -> [a]
reverse ([Topic] -> [Topic])
-> (PrevTopics -> [Topic]) -> PrevTopics -> [Topic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrevTopics -> [Topic]
getPrevTopics

-- | This function is a variant of 'DL.pprWindowSet' which takes a topic configuration
-- and a pretty-printing record 'PP'. It will show the list of topics sorted historically
-- and highlighting topics with urgent windows.
pprWindowSet :: TopicConfig -> PP -> X String
pprWindowSet :: TopicConfig -> PP -> X Topic
pprWindowSet tg :: TopicConfig
tg pp :: PP
pp = do
    WindowSet
winset <- (XState -> WindowSet) -> X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
    [Window]
urgents <- X [Window]
readUrgents
    let empty_workspaces :: [Topic]
empty_workspaces = (Workspace Topic (Layout Window) Window -> Topic)
-> [Workspace Topic (Layout Window) Window] -> [Topic]
forall a b. (a -> b) -> [a] -> [b]
map Workspace Topic (Layout Window) Window -> Topic
forall i l a. Workspace i l a -> i
W.tag ([Workspace Topic (Layout Window) Window] -> [Topic])
-> [Workspace Topic (Layout Window) Window] -> [Topic]
forall a b. (a -> b) -> a -> b
$ (Workspace Topic (Layout Window) Window -> Bool)
-> [Workspace Topic (Layout Window) Window]
-> [Workspace Topic (Layout Window) Window]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe (Stack Window) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (Stack Window) -> Bool)
-> (Workspace Topic (Layout Window) Window -> Maybe (Stack Window))
-> Workspace Topic (Layout Window) Window
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Workspace Topic (Layout Window) Window -> Maybe (Stack Window)
forall i l a. Workspace i l a -> Maybe (Stack a)
W.stack) ([Workspace Topic (Layout Window) Window]
 -> [Workspace Topic (Layout Window) Window])
-> [Workspace Topic (Layout Window) Window]
-> [Workspace Topic (Layout Window) Window]
forall a b. (a -> b) -> a -> b
$ WindowSet -> [Workspace Topic (Layout Window) Window]
forall i l a s sd. StackSet i l a s sd -> [Workspace i l a]
W.workspaces WindowSet
winset
        maxDepth :: Int
maxDepth = TopicConfig -> Int
maxTopicHistory TopicConfig
tg
    Topic -> (Topic -> Bool) -> X ()
setLastFocusedTopic (Workspace Topic (Layout Window) Window -> Topic
forall i l a. Workspace i l a -> i
W.tag (Workspace Topic (Layout Window) Window -> Topic)
-> (WindowSet -> Workspace Topic (Layout Window) Window)
-> WindowSet
-> Topic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen Topic (Layout Window) Window ScreenId ScreenDetail
-> Workspace Topic (Layout Window) Window
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace (Screen Topic (Layout Window) Window ScreenId ScreenDetail
 -> Workspace Topic (Layout Window) Window)
-> (WindowSet
    -> Screen Topic (Layout Window) Window ScreenId ScreenDetail)
-> WindowSet
-> Workspace Topic (Layout Window) Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet
-> Screen Topic (Layout Window) Window ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current (WindowSet -> Topic) -> WindowSet -> Topic
forall a b. (a -> b) -> a -> b
$ WindowSet
winset)
                        (Topic -> [Topic] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Topic]
empty_workspaces)
    [Topic]
lastWs <- X [Topic]
getLastFocusedTopics
    let depth :: Topic -> Int
depth topic :: Topic
topic = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Topic -> [Topic] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Topic
topic ([Topic]
lastWs [Topic] -> [Topic] -> [Topic]
forall a. [a] -> [a] -> [a]
++ [Topic
topic])
        add_depth :: (PP -> Topic -> c) -> Topic -> c
add_depth proj :: PP -> Topic -> c
proj topic :: Topic
topic = PP -> Topic -> c
proj PP
pp (Topic -> c) -> ShowS -> Topic -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Topic
topicTopic -> ShowS
forall a. [a] -> [a] -> [a]
++":")Topic -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> (Int -> Topic) -> Int -> Topic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Topic
forall a. Show a => a -> Topic
show) (Int -> Topic) -> (Topic -> Int) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Topic -> Int
depth (Topic -> c) -> Topic -> c
forall a b. (a -> b) -> a -> b
$ Topic
topic
        pp' :: PP
pp' = PP
pp { ppHidden :: ShowS
ppHidden = (PP -> ShowS) -> ShowS
forall c. (PP -> Topic -> c) -> Topic -> c
add_depth PP -> ShowS
ppHidden, ppVisible :: ShowS
ppVisible = (PP -> ShowS) -> ShowS
forall c. (PP -> Topic -> c) -> Topic -> c
add_depth PP -> ShowS
ppVisible }
        sortWindows :: [Workspace Topic l a] -> [Workspace Topic l a]
sortWindows = Int -> [Workspace Topic l a] -> [Workspace Topic l a]
forall a. Int -> [a] -> [a]
take Int
maxDepth ([Workspace Topic l a] -> [Workspace Topic l a])
-> ([Workspace Topic l a] -> [Workspace Topic l a])
-> [Workspace Topic l a]
-> [Workspace Topic l a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Workspace Topic l a -> Workspace Topic l a -> Ordering)
-> [Workspace Topic l a] -> [Workspace Topic l a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Workspace Topic l a -> Int)
-> Workspace Topic l a -> Workspace Topic l a -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((Workspace Topic l a -> Int)
 -> Workspace Topic l a -> Workspace Topic l a -> Ordering)
-> (Workspace Topic l a -> Int)
-> Workspace Topic l a
-> Workspace Topic l a
-> Ordering
forall a b. (a -> b) -> a -> b
$ Topic -> Int
depth (Topic -> Int)
-> (Workspace Topic l a -> Topic) -> Workspace Topic l a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Workspace Topic l a -> Topic
forall i l a. Workspace i l a -> i
W.tag)
    Topic -> X Topic
forall (m :: * -> *) a. Monad m => a -> m a
return (Topic -> X Topic) -> Topic -> X Topic
forall a b. (a -> b) -> a -> b
$ ([Workspace Topic (Layout Window) Window]
 -> [Workspace Topic (Layout Window) Window])
-> [Window] -> PP -> WindowSet -> Topic
DL.pprWindowSet [Workspace Topic (Layout Window) Window]
-> [Workspace Topic (Layout Window) Window]
forall l a. [Workspace Topic l a] -> [Workspace Topic l a]
sortWindows [Window]
urgents PP
pp' WindowSet
winset

-- | Given a prompt configuration and a topic configuration, triggers the action associated with
-- the topic given in prompt.
topicActionWithPrompt :: XPConfig -> TopicConfig -> X ()
topicActionWithPrompt :: XPConfig -> TopicConfig -> X ()
topicActionWithPrompt xp :: XPConfig
xp tg :: TopicConfig
tg = XPConfig -> (Topic -> X ()) -> X ()
workspacePrompt XPConfig
xp ((X () -> X () -> X ())
-> (Topic -> X ()) -> (Topic -> X ()) -> Topic -> X ()
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 X () -> X () -> X ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>) (TopicConfig -> Topic -> X ()
switchTopic TopicConfig
tg) (TopicConfig -> Topic -> X ()
topicAction TopicConfig
tg))

-- | Given a configuration and a topic, triggers the action associated with the given topic.
topicAction :: TopicConfig -> Topic -> X ()
topicAction :: TopicConfig -> Topic -> X ()
topicAction tg :: TopicConfig
tg topic :: Topic
topic = X () -> Maybe (X ()) -> X ()
forall a. a -> Maybe a -> a
fromMaybe (TopicConfig -> Topic -> X ()
defaultTopicAction TopicConfig
tg Topic
topic) (Maybe (X ()) -> X ()) -> Maybe (X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ Topic -> Map Topic (X ()) -> Maybe (X ())
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Topic
topic (Map Topic (X ()) -> Maybe (X ()))
-> Map Topic (X ()) -> Maybe (X ())
forall a b. (a -> b) -> a -> b
$ TopicConfig -> Map Topic (X ())
topicActions TopicConfig
tg

-- | Trigger the action associated with the current topic.
currentTopicAction :: TopicConfig -> X ()
currentTopicAction :: TopicConfig -> X ()
currentTopicAction tg :: TopicConfig
tg = TopicConfig -> Topic -> X ()
topicAction TopicConfig
tg (Topic -> X ()) -> X Topic -> X ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (XState -> Topic) -> X Topic
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Workspace Topic (Layout Window) Window -> Topic
forall i l a. Workspace i l a -> i
W.tag (Workspace Topic (Layout Window) Window -> Topic)
-> (XState -> Workspace Topic (Layout Window) Window)
-> XState
-> Topic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen Topic (Layout Window) Window ScreenId ScreenDetail
-> Workspace Topic (Layout Window) Window
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace (Screen Topic (Layout Window) Window ScreenId ScreenDetail
 -> Workspace Topic (Layout Window) Window)
-> (XState
    -> Screen Topic (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> Workspace Topic (Layout Window) Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet
-> Screen Topic (Layout Window) Window ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current (WindowSet
 -> Screen Topic (Layout Window) Window ScreenId ScreenDetail)
-> (XState -> WindowSet)
-> XState
-> Screen Topic (Layout Window) Window ScreenId ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset)

-- | Switch to the given topic.
switchTopic :: TopicConfig -> Topic -> X ()
switchTopic :: TopicConfig -> Topic -> X ()
switchTopic tg :: TopicConfig
tg topic :: Topic
topic = do
  (WindowSet -> WindowSet) -> X ()
windows ((WindowSet -> WindowSet) -> X ())
-> (WindowSet -> WindowSet) -> X ()
forall a b. (a -> b) -> a -> b
$ Topic -> WindowSet -> WindowSet
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 Topic
topic
  [Window]
wins <- (XState -> [Window]) -> X [Window]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Maybe (Stack Window) -> [Window]
forall a. Maybe (Stack a) -> [a]
W.integrate' (Maybe (Stack Window) -> [Window])
-> (XState -> Maybe (Stack Window)) -> XState -> [Window]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Workspace Topic (Layout Window) Window -> Maybe (Stack Window)
forall i l a. Workspace i l a -> Maybe (Stack a)
W.stack (Workspace Topic (Layout Window) Window -> Maybe (Stack Window))
-> (XState -> Workspace Topic (Layout Window) Window)
-> XState
-> Maybe (Stack Window)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen Topic (Layout Window) Window ScreenId ScreenDetail
-> Workspace Topic (Layout Window) Window
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace (Screen Topic (Layout Window) Window ScreenId ScreenDetail
 -> Workspace Topic (Layout Window) Window)
-> (XState
    -> Screen Topic (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> Workspace Topic (Layout Window) Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet
-> Screen Topic (Layout Window) Window ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current (WindowSet
 -> Screen Topic (Layout Window) Window ScreenId ScreenDetail)
-> (XState -> WindowSet)
-> XState
-> Screen Topic (Layout Window) Window ScreenId ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset)
  Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Window] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Window]
wins) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ TopicConfig -> Topic -> X ()
topicAction TopicConfig
tg Topic
topic

-- | Switch to the Nth last focused topic or failback to the 'defaultTopic'.
switchNthLastFocused :: TopicConfig -> Int -> X ()
switchNthLastFocused :: TopicConfig -> Int -> X ()
switchNthLastFocused tg :: TopicConfig
tg depth :: Int
depth = do
  [Topic]
lastWs <- X [Topic]
getLastFocusedTopics
  TopicConfig -> Topic -> X ()
switchTopic TopicConfig
tg (Topic -> X ()) -> Topic -> X ()
forall a b. (a -> b) -> a -> b
$ ([Topic]
lastWs [Topic] -> [Topic] -> [Topic]
forall a. [a] -> [a] -> [a]
++ Topic -> [Topic]
forall a. a -> [a]
repeat (TopicConfig -> Topic
defaultTopic TopicConfig
tg)) [Topic] -> Int -> Topic
forall a. [a] -> Int -> a
!! Int
depth

-- | Shift the focused window to the Nth last focused topic, or fallback to doing nothing.
shiftNthLastFocused :: Int -> X ()
shiftNthLastFocused :: Int -> X ()
shiftNthLastFocused n :: Int
n = do
  Maybe Topic
ws <- ([Topic] -> Maybe Topic) -> X [Topic] -> X (Maybe Topic)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Topic] -> Maybe Topic
forall a. [a] -> Maybe a
listToMaybe ([Topic] -> Maybe Topic)
-> ([Topic] -> [Topic]) -> [Topic] -> Maybe Topic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Topic] -> [Topic]
forall a. Int -> [a] -> [a]
drop Int
n) X [Topic]
getLastFocusedTopics
  Maybe Topic -> (Topic -> X ()) -> X ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Topic
ws ((Topic -> X ()) -> X ()) -> (Topic -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ (WindowSet -> WindowSet) -> X ()
windows ((WindowSet -> WindowSet) -> X ())
-> (Topic -> WindowSet -> WindowSet) -> Topic -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Topic -> WindowSet -> WindowSet
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

-- | Returns the directory associated with current topic returns the empty string otherwise.
currentTopicDir :: TopicConfig -> X String
currentTopicDir :: TopicConfig -> X Topic
currentTopicDir tg :: TopicConfig
tg = do
  Topic
topic <- (XState -> Topic) -> X Topic
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Workspace Topic (Layout Window) Window -> Topic
forall i l a. Workspace i l a -> i
W.tag (Workspace Topic (Layout Window) Window -> Topic)
-> (XState -> Workspace Topic (Layout Window) Window)
-> XState
-> Topic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen Topic (Layout Window) Window ScreenId ScreenDetail
-> Workspace Topic (Layout Window) Window
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace (Screen Topic (Layout Window) Window ScreenId ScreenDetail
 -> Workspace Topic (Layout Window) Window)
-> (XState
    -> Screen Topic (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> Workspace Topic (Layout Window) Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet
-> Screen Topic (Layout Window) Window ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current (WindowSet
 -> Screen Topic (Layout Window) Window ScreenId ScreenDetail)
-> (XState -> WindowSet)
-> XState
-> Screen Topic (Layout Window) Window ScreenId ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset)
  Topic -> X Topic
forall (m :: * -> *) a. Monad m => a -> m a
return (Topic -> X Topic)
-> (Map Topic Topic -> Topic) -> Map Topic Topic -> X Topic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Topic -> Maybe Topic -> Topic
forall a. a -> Maybe a -> a
fromMaybe "" (Maybe Topic -> Topic)
-> (Map Topic Topic -> Maybe Topic) -> Map Topic Topic -> Topic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Topic -> Map Topic Topic -> Maybe Topic
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Topic
topic (Map Topic Topic -> X Topic) -> Map Topic Topic -> X Topic
forall a b. (a -> b) -> a -> b
$ TopicConfig -> Map Topic Topic
topicDirs TopicConfig
tg

-- | Check the given topic configuration for duplicates topics or undefined topics.
checkTopicConfig :: [Topic] -> TopicConfig -> IO ()
checkTopicConfig :: [Topic] -> TopicConfig -> IO ()
checkTopicConfig tags :: [Topic]
tags tg :: TopicConfig
tg = do
    -- tags <- gets $ map W.tag . workspaces . windowset

    let
      seenTopics :: [Topic]
seenTopics = [Topic] -> [Topic]
forall a. Eq a => [a] -> [a]
nub ([Topic] -> [Topic]) -> [Topic] -> [Topic]
forall a b. (a -> b) -> a -> b
$ [Topic] -> [Topic]
forall a. Ord a => [a] -> [a]
sort ([Topic] -> [Topic]) -> [Topic] -> [Topic]
forall a b. (a -> b) -> a -> b
$ Map Topic Topic -> [Topic]
forall k a. Map k a -> [k]
M.keys (TopicConfig -> Map Topic Topic
topicDirs TopicConfig
tg) [Topic] -> [Topic] -> [Topic]
forall a. [a] -> [a] -> [a]
++ Map Topic (X ()) -> [Topic]
forall k a. Map k a -> [k]
M.keys (TopicConfig -> Map Topic (X ())
topicActions TopicConfig
tg)
      dups :: [Topic]
dups       = [Topic]
tags [Topic] -> [Topic] -> [Topic]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Topic] -> [Topic]
forall a. Eq a => [a] -> [a]
nub [Topic]
tags
      diffTopic :: [Topic]
diffTopic  = [Topic]
seenTopics [Topic] -> [Topic] -> [Topic]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Topic] -> [Topic]
forall a. Ord a => [a] -> [a]
sort [Topic]
tags
      check :: t a -> Topic -> IO ()
check lst :: t a
lst msg :: Topic
msg = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
lst) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Topic -> IO ()
xmessage (Topic -> IO ()) -> Topic -> IO ()
forall a b. (a -> b) -> a -> b
$ Topic
msg Topic -> ShowS
forall a. [a] -> [a] -> [a]
++ " (tags): " Topic -> ShowS
forall a. [a] -> [a] -> [a]
++ t a -> Topic
forall a. Show a => a -> Topic
show t a
lst

    [Topic] -> Topic -> IO ()
forall (t :: * -> *) a.
(Foldable t, Show (t a)) =>
t a -> Topic -> IO ()
check [Topic]
diffTopic "Seen but missing topics/workspaces"
    [Topic] -> Topic -> IO ()
forall (t :: * -> *) a.
(Foldable t, Show (t a)) =>
t a -> Topic -> IO ()
check [Topic]
dups      "Duplicate topics/workspaces"

-- | Display the given message using the @xmessage@ program.
xmessage :: String -> IO ()
xmessage :: Topic -> IO ()
xmessage s :: Topic
s = do
  Handle
h <- Topic -> IO Handle
forall (m :: * -> *). MonadIO m => Topic -> m Handle
spawnPipe "xmessage -file -"
  Handle -> Topic -> IO ()
hPutStr Handle
h Topic
s
  Handle -> IO ()
hClose Handle
h