New module: XMonad.Actions.TopicSpace

Ignore-this: 4c20592ea6ca74f38545c5a1a002ef91

darcs-hash:20090419085239-eb2e9-b81c0e529e0ea8664b1ab557472df72706c9d185.gz

1 files changed, 331 insertions, 0 deletions

diff --git a/XMonad/Actions/TopicSpace.hs b/XMonad/Actions/TopicSpace.hs
new file mode 100644
index 0000000..b60114a
--- /dev/null
+++ b/XMonad/Actions/TopicSpace.hs
@@ -0,0 +1,331 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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.
+--
+-- This module allow 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 will 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 that will be triggered
+-- when switching to a topic that does not have any windows in it. So one can
+-- attach our mail client to the mail topic, some terminals in the right
+-- directory for the xmonad topic... This package also provides a nice way to
+-- display your topics in a historical way using a custom `pprWindowSet'
+-- function. You can also easily switch to recents topics using this history
+-- of last focused topics.
+--
+-- Here is an example of configuration using TopicSpace:
+--
+-- @
+--  myTopicConfig :: TopicConfig
+--  myTopicConfig = TopicConfig
+--    { allTopics =
+--        [ \"dashboard\" -- the first one
+--        , \"admin\", \"build\", \"cleaning\", \"conf\", \"darcs\", \"haskell\", \"irc\"
+--        , \"mail\", \"movie\", \"music\", \"talk\", \"text\", \"tools\", \"web\", \"xmonad\"
+--        , \"yi\", \"documents\", \"twitter\", \"pdf\"
+--        ]
+--    , 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\"
+--    , maxTopicHistory = 10
+--    , 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 =
+--    [ ((modMask              , xK_n     ), spawnShell) -- %! Launch terminal
+--    , ((modMask              , xK_a     ), currentTopicAction myTopicConfig)
+--    , ((modMask              , xK_g     ), promptedGoto)
+--    , ((modMask .|. shiftMask, xK_g     ), promptedShift)
+--    ...
+--    ]
+--    ++
+--    [ ((modMask, k), switchNthLastFocused defaultTopic 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 myTopicConfig
+--      myLogHook <- makeMyLogHook
+--      return $ defaultConfig
+--           { borderWidth = 1 -- Width of the window border in pixels.
+--           , workspaces = allTopics myTopicConfig
+--           , layoutHook = myModifiers myLayouts
+--           , 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
+-- @
+module XMonad.Actions.TopicSpace
+  ( Topic
+  , Dir
+  , TopicConfig(..)
+  , getLastFocusedTopics
+  , setLastFocusedTopic
+  , pprWindowSet
+  , topicActionWithPrompt
+  , topicAction
+  , currentTopicAction
+  , switchTopic
+  , switchNthLastFocused
+  , currentTopicDir
+  , checkTopicConfig
+  , (>*>)
+  )
+where
+
+import XMonad
+
+import Data.List
+import Data.Maybe (fromMaybe, isNothing)
+import Data.Ord
+import qualified Data.Map as M
+import Graphics.X11.Xlib
+import Control.Monad ((=<<),liftM2,when,unless,replicateM_)
+import System.IO
+import Foreign.C.String (castCCharToChar,castCharToCChar)
+
+import XMonad.Operations
+import Control.Applicative ((<$>))
+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)
+
+-- | An alias for @flip replicateM_@
+(>*>) :: Monad m => m a -> Int -> m ()
+(>*>) = flip 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 { allTopics          :: [Topic]
+                                 -- ^ You have to give a list of topics,
+                                 -- this must the be same list than the workspaces field 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.
+                               , topicDirs          :: M.Map Topic Dir
+                                 -- ^ This mapping associate a directory to each topic.
+                               , topicActions       :: M.Map Topic (X ())
+                                 -- ^ This mapping associate an action to trigger when
+                                 -- switching to a given topic which workspace is empty.
+                               , defaultTopicAction :: Topic -> X ()
+                                 -- ^ This is the default topic action.
+                               , defaultTopic       :: Topic
+                                 -- ^ This is the default topic.
+                               , 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.
+                               }
+
+-- | Returns the list of last focused workspaces the empty list otherwise.
+-- This function rely on a reserved property namely _XMONAD_LAST_FOCUSED_WORKSPACES.
+getLastFocusedTopics :: X [String]
+getLastFocusedTopics = getStringListProp "_XMONAD_LAST_FOCUSED_WORKSPACES"
+
+-- | 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 :: TopicConfig -> Topic -> (Topic -> Bool) -> X ()
+setLastFocusedTopic tg w predicate =
+  getLastFocusedTopics >>=
+    setStringListProp "_XMONAD_LAST_FOCUSED_WORKSPACES"
+    . take (maxTopicHistory tg) . nub . (w:) . filter predicate
+
+-- | 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 tg pp = do
+    winset <- gets windowset
+    urgents <- readUrgents
+    let empty_workspaces = map W.tag $ filter (isNothing . W.stack) $ W.workspaces winset
+        maxDepth = maxTopicHistory tg
+    setLastFocusedTopic tg (W.tag . W.workspace . W.current $ winset)
+                           (`notElem` empty_workspaces)
+    lastWs <- getLastFocusedTopics
+    let depth topic = elemIndex topic lastWs
+        add_depth proj topic = proj pp $ maybe topic (((topic++":")++) . show) $ depth topic
+        pp' = pp { ppHidden = add_depth ppHidden, ppVisible = add_depth ppVisible }
+        sortWindows = take (maxDepth - 1) . sortBy (comparing $ fromMaybe maxDepth . depth . W.tag)
+    return $ DL.pprWindowSet sortWindows urgents pp' winset
+
+-- | Given a prompt configuration and a topic configuration, triggers the action associated with
+-- the topic given in prompt.
+topicActionWithPrompt :: XPConfig -> TopicConfig -> X ()
+topicActionWithPrompt xp tg = workspacePrompt xp (liftM2 (>>) (switchTopic tg) (topicAction tg))
+
+-- | Given a configuration and a topic, triggers the action associated with the given topic.
+topicAction :: TopicConfig -> Topic -> X ()
+topicAction tg topic = fromMaybe (defaultTopicAction tg topic) $ M.lookup topic $ topicActions tg
+
+-- | Trigger the action associated with the current topic.
+currentTopicAction :: TopicConfig -> X ()
+currentTopicAction tg = topicAction tg =<< gets (W.tag . W.workspace . W.current . windowset)
+
+-- | Switch to the given topic.
+switchTopic :: TopicConfig -> Topic -> X ()
+switchTopic tg topic = do
+  windows $ W.greedyView topic
+  wins <- gets (W.integrate' . W.stack . W.workspace . W.current . windowset)
+  when (null wins) $ topicAction tg topic
+
+-- | Switch to the Nth last focused topic or failback to the 'defaultTopic'.
+switchNthLastFocused ::TopicConfig -> Int -> X ()
+switchNthLastFocused tg depth = do
+  lastWs <- getLastFocusedTopics
+  switchTopic tg $ (lastWs ++ repeat (defaultTopic tg)) !! depth
+
+-- | Returns the directory associated with current topic returns the empty string otherwise.
+currentTopicDir :: TopicConfig -> X String
+currentTopicDir tg = do
+  topic <- gets (W.tag . W.workspace . W.current . windowset)
+  return . fromMaybe "" . M.lookup topic $ topicDirs tg
+
+-- | Check the given topic configuration for duplicates topics or undefined topics.
+checkTopicConfig :: TopicConfig -> IO ()
+checkTopicConfig tg = do
+    unless (null diffTopic) $ xmessage $ "Seen but missing workspaces (tags): " ++ show diffTopic
+    unless (null dups)     $ xmessage $ "Duplicate workspaces (tags): " ++ show dups
+  where
+    seenTopics = nub $ sort $ M.keys (topicDirs tg) ++ M.keys (topicActions tg)
+    dups       = tags \\ nub tags
+    diffTopic  = seenTopics \\ sort tags
+    tags       = allTopics tg
+
+type StringProp = String
+
+withStringProp :: StringProp -> (Display -> Window -> Atom -> X a) -> X a
+withStringProp prop f =
+  withDisplay $ \dpy -> do
+    rootw <- asks theRoot
+    a     <- io $ internAtom dpy prop False
+    f dpy rootw a
+
+-- | Get the name of a string property and returns it as a 'Maybe'.
+getStringProp :: StringProp -> X (Maybe String)
+getStringProp prop =
+  withStringProp prop $ \dpy rootw a -> do
+    p <- io $ getWindowProperty8 dpy a rootw
+    return $ map castCCharToChar <$> p
+
+-- | Set the value of a string property.
+setStringProp :: StringProp -> String -> X ()
+setStringProp prop string =
+  withStringProp prop $ \dpy rootw a ->
+    io $ changeProperty8 dpy rootw a a propModeReplace $ map castCharToCChar string
+
+-- | Given a property name, returns its contents as a list. It uses the empty
+-- list as default value.
+getStringListProp :: StringProp -> X [String]
+getStringListProp prop = return . maybe [] words =<< getStringProp prop
+
+-- | Given a property name and a list, sets the value of this property with
+-- the list given as argument.
+setStringListProp :: StringProp -> [String] -> X ()
+setStringListProp prop = setStringProp prop . unwords
+
+-- | Display the given message using the @xmessage@ program.
+xmessage :: String -> IO ()
+xmessage s = do
+  h <- spawnPipe "xmessage -file -"
+  hPutStr h s
+  hClose h
+