TagWindows

Functions to work with window tags, including a XPrompt interface.
These are stored in the window property "_XMONAD_TAGS"

Adding also functions shiftHere and shiftToScreen (move to another module?).

darcs-hash:20071002190526-eb3a1-abd13cabb9087010c0a4b3f4cf22b9ffe5fc422c.gz

1 files changed, 204 insertions, 0 deletions

diff --git a/TagWindows.hs b/TagWindows.hs
new file mode 100644
index 0000000..76ef3bf
--- /dev/null
+++ b/TagWindows.hs
@@ -0,0 +1,204 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module       : XMonadContrib.TagWindows
+-- Copyright    : (c) Karsten Schoelzel <kuser@gmx.de>
+-- License      : BSD
+--
+-- Maintainer   : Karsten Schoelzel <kuser@gmx.de>
+-- Stability    : unstable
+-- Portability  : unportable
+--
+-- Functions for tagging windows and selecting them by tags.
+-----------------------------------------------------------------------------
+
+module XMonadContrib.TagWindows (
+                 -- * Usage
+                 -- $usage
+                 addTag, delTag, unTag,
+                 setTags, getTags,
+                 withTaggedP,  withTaggedGlobalP, withFocusedP,
+                 withTagged ,  withTaggedGlobal ,
+                 focusUpTagged,   focusUpTaggedGlobal,
+                 focusDownTagged, focusDownTaggedGlobal,
+                 shiftHere, shiftToScreen,
+                 tagPrompt,
+                 tagDelPrompt
+                 ) where
+
+import Data.List (nub,concat,sortBy)
+
+import Control.Monad.State
+import StackSet hiding (filter)
+import Operations (windows, withFocused)
+
+import Graphics.X11.Xlib
+import Graphics.X11.Xlib.Extras
+
+import XMonadContrib.XPrompt
+import XMonad
+
+-- $usage
+-- 
+-- To use window tags add in your Config.hs:
+--
+-- > import XMonadContrib.TagWindows
+-- > import XMonadContrib.XPrompt    -- to use tagPrompt
+-- 
+-- and add keybindings like as follows:
+--    , ((modMask,                 xK_f  ), withFocused (addTag "abc")) 
+--    , ((modMask .|. controlMask, xK_f  ), withFocused (delTag "abc")) 
+--    , ((modMask .|. shiftMask,   xK_f  ), withTaggedGlobal "abc" sink) 
+--    , ((modMask,                 xK_d  ), withTaggedP "abc" (shiftWin "2")) 
+--    , ((modMask .|. shiftMask,   xK_d  ), withTaggedGlobalP "abc" shiftHere) 
+--    , ((modMask .|. controlMask, xK_d  ), focusUpTaggedGlobal "abc") 
+--    , ((modMask,                 xK_g  ), tagPrompt defaultXPConfig (\s -> withFocused (addTag s))) 
+--    , ((modMask .|. controlMask, xK_g  ), tagDelPrompt defaultXPConfig)
+--    , ((modMask .|. shiftMask,   xK_g  ), tagPrompt defaultXPConfig (\s -> withTaggedGlobal s float))
+--    , ((modWinMask,              xK_g  ), tagPrompt defaultXPConfig (\s -> withTaggedP s (shiftWin "2")))
+--    , ((modWinMask .|. shiftMask, xK_g  ), tagPrompt defaultXPConfig (\s -> withTaggedGlobalP s shiftHere))
+--    , ((modWinMask .|. controlMask, xK_g), tagPrompt defaultXPConfig (\s -> focusUpTaggedGlobal s)) 
+--
+-- NOTE: Tags are saved as space seperated string and split with 'unwords' thus
+--       if you add a tag "a b" the window will have the tags "a" and "b" but not "a b".
+--
+-- %import XMonadContrib.TagWindows
+-- %import XMonadContrib.XPrompt        -- to use tagPrompt
+
+-- set multiple tags for a window at once (overriding any previous tags)
+setTags :: [String] -> Window -> X ()
+setTags = setTag . unwords
+
+-- set a tag for a window (overriding any previous tags)
+-- writes it to the "_XMONAD_TAGS" window property
+setTag :: String -> Window -> X ()
+setTag s w = withDisplay $ \d ->
+    io $ internAtom d "_XMONAD_TAGS" False >>= setTextProperty d w s
+
+-- read all tags of a window
+-- reads from the "_XMONAD_TAGS" window property
+getTags :: Window -> X [String]
+getTags w = withDisplay $ \d ->
+    io $ catch (internAtom d "_XMONAD_TAGS" False >>=
+                getTextProperty d w >>=
+                wcTextPropertyToTextList d)
+               (\_ -> return [[]])
+    >>= return . words . unwords
+
+-- check a window for the given tag
+hasTag :: String -> Window -> X Bool
+hasTag s w = (s `elem`) `liftM` getTags w
+
+-- add a tag to the existing ones
+addTag :: String -> Window -> X ()
+addTag s w = do
+    tags <- getTags w
+    if (s `notElem` tags) then setTags (s:tags) w else return ()
+
+-- remove a tag from a window, if it exists
+delTag :: String -> Window -> X ()
+delTag s w = do
+    tags <- getTags w
+    setTags (filter (/= s) tags) w
+
+-- remove all tags
+unTag :: Window -> X ()
+unTag = setTag ""
+
+-- Move the focus in a group of windows, which share the same given tag.
+-- The Global variants move through all workspaces, whereas the other
+-- ones operate only on the current workspace
+focusUpTagged, focusDownTagged, focusUpTaggedGlobal, focusDownTaggedGlobal :: String -> X ()
+focusUpTagged         = focusTagged' (reverse . wsToList)
+focusDownTagged       = focusTagged' wsToList
+focusUpTaggedGlobal   = focusTagged' (reverse . wsToListGlobal)
+focusDownTaggedGlobal = focusTagged' wsToListGlobal
+
+-- 
+wsToList :: (Ord i) => StackSet i l a s sd -> [a]
+wsToList ws = crs ++ cls
+    where
+        (crs, cls) = (cms down, cms (reverse . up))
+        cms f = maybe [] f (stack . workspace . current $ ws)
+
+wsToListGlobal :: (Ord i) => StackSet i l a s sd -> [a]
+wsToListGlobal ws = concat ([crs] ++ rws ++ lws ++ [cls])
+    where
+        curtag = tag . workspace . current $ ws
+        (crs, cls) = (cms down, cms (reverse . up))
+        cms f = maybe [] f (stack . workspace . current $ ws)
+        (lws, rws) = (mws (<), mws (>))
+        mws cmp = map (integrate' . stack) . sortByTag . filter (\w -> tag w `cmp` curtag) . workspaces $ ws
+        sortByTag = sortBy (\x y -> compare (tag x) (tag y))
+
+focusTagged' :: (WindowSet -> [Window]) -> String -> X ()
+focusTagged' wl t = gets windowset >>= findM (hasTag t) . wl >>=
+    maybe (return ()) (windows . focusWindow)
+
+findM :: (Monad m) => (a -> m Bool) -> [a] -> m (Maybe a)
+findM _ []      = return Nothing
+findM p (x:xs)  = do b <- p x
+                     if b then return (Just x) else findM p xs
+
+-- apply a pure function to windows with a tag
+withTaggedP, withTaggedGlobalP :: String -> (Window -> WindowSet -> WindowSet) -> X ()
+withTaggedP       t f = withTagged'       t (winMap f)
+withTaggedGlobalP t f = withTaggedGlobal' t (winMap f)
+
+winMap :: (Window -> WindowSet -> WindowSet) -> [Window] -> X ()
+winMap f tw = when (tw /= []) (windows $ foldl1 (.) (map f tw))
+
+withTagged, withTaggedGlobal :: String -> (Window -> X ()) -> X ()
+withTagged       t f = withTagged'       t (mapM_ f)
+withTaggedGlobal t f = withTaggedGlobal' t (mapM_ f)
+
+withTagged' :: String -> ([Window] -> X ()) -> X ()
+withTagged' t m = gets windowset >>=
+    filterM (hasTag t) . integrate' . stack . workspace . current >>= m
+
+withTaggedGlobal' :: String -> ([Window] -> X ()) -> X ()
+withTaggedGlobal' t m = gets windowset >>=
+    filterM (hasTag t) . concat . map (integrate' . stack) . workspaces >>= m
+
+withFocusedP :: (Window -> WindowSet -> WindowSet) -> X ()
+withFocusedP f = withFocused $ windows . f
+
+shiftHere :: (Ord a, Eq s, Eq i) => a -> StackSet i l a s sd -> StackSet i l a s sd
+shiftHere w s = shiftWin (tag . workspace . current $ s) w s
+
+shiftToScreen :: (Ord a, Eq s, Eq i) => s -> a -> StackSet i l a s sd -> StackSet i l a s sd
+shiftToScreen sid w s = case filter (\m -> sid /= screen m) ((current s):(visible s)) of
+                                []      -> s
+                                (t:_)   -> shiftWin (tag . workspace $ t) w s
+
+data TagPrompt = TagPrompt
+
+instance XPrompt TagPrompt where
+    showXPrompt TagPrompt = "Select Tag:   "
+
+
+tagPrompt :: XPConfig -> (String -> X ()) -> X ()
+tagPrompt c f = do
+  sc <- tagComplList
+  mkXPrompt TagPrompt c (mkComplFunFromList' sc) f
+
+tagComplList :: X [String]
+tagComplList = gets (concat . map (integrate' . stack) . workspaces . windowset) >>=
+    mapM getTags >>=
+    return . nub . concat
+
+
+tagDelPrompt :: XPConfig -> X ()
+tagDelPrompt c = do
+  sc <- tagDelComplList
+  if (sc /= []) 
+    then mkXPrompt TagPrompt c (mkComplFunFromList' sc) (\s -> withFocused (delTag s))
+    else return ()
+
+tagDelComplList :: X [String]
+tagDelComplList = gets windowset >>= maybe (return []) getTags . peek
+
+
+mkComplFunFromList' :: [String] -> String -> IO [String]
+mkComplFunFromList' l [] = return l
+mkComplFunFromList' l s =
+  return $ filter (\x -> take (length s) x == s) l