[Xmonad] Window tags

[Karsten Schoelzel]

Hi,

today I added the ability to add tags to windows. Some uses which are
possible with them right now:
* move a tag group of windows to another workspace at once
* get them back without switching to the other workspace
* change focus only in the group of windows with a specified tag
    - if there is only one of them at the workspace this means
      specifically that you can jump to a specific window wherever the
      focus is and wherever the window is

Would be nice to get tags assigned automatically, but i haven't thought
about how to implement this ;-)

As it is work in progress (docs and cleanup needed) I would welcome
opinions suggestions as to what people might want to do with tagging.
Most parts of the code are in a Contrib module but where are also
changes in StackSet to store the tags therein. (Yesterday I wrote a
similar tagging module which stored the tags in the X Server in a
text-property of the window. But that turned out to be not very nice to
work with. If anybody wants to see that code, just ask :-))

Regards,
Karsten

Example settings in Config.hs
    , ((modMask,               xK_f     ), withFocusedX (addTag "abc")) 
    , ((modMask .|. controlMask, xK_f     ), withFocusedX (delTag "abc")) 
    -- Sink all windows with tag "abc" on all workspaces 
    , ((modMask .|. shiftMask, xK_f     ), withTaggedGlobalM "abc" sink) 

    -- Move all windows with tag "abc" to workspace "2"
    , ((modWinMask,            xK_f     ), withTagged "abc" (shiftX "2")) 
    -- Move all windows with tag "abc" from all workspaces to the current workspace
    , ((modWinMask .|. shiftMask, xK_f  ), withTaggedGlobal "abc" shiftHere)
    -- Change focus with "abc" windows
    , ((modWinMask .|. controlMask, xK_f  ), focusTaggedUp "abc") 

diff -rN -u old-xmonad/StackSet.hs new-xmonad/StackSet.hs
--- old-xmonad/StackSet.hs	2007-09-08 00:36:44.000000000 +0200
+++ new-xmonad/StackSet.hs	2007-09-08 00:36:44.000000000 +0200
@@ -22,11 +22,11 @@
         -- *  Operations on the current stack
         -- $stackOperations
         peek, index, integrate, integrate', differentiate,
-        focusUp, focusDown,
-        focusWindow, tagMember, member, findIndex,
+        focusUp, focusDown, focusUp',
+        focusWindow, workspaces, tagMember, member, findIndex,
         -- * Modifying the stackset
         -- $modifyStackset
-        insertUp, delete, filter,
+        insertUp, delete, deletetmp, filter,
         -- * Setting the master window
         -- $settingMW
         swapMaster, swapUp, swapDown, modify, modify', float, sink, -- needed by users
@@ -39,6 +39,7 @@
 import Data.Maybe   (listToMaybe)
 import qualified Data.List as L (delete,deleteBy,find,splitAt,filter)
 import qualified Data.Map  as M (Map,insert,delete,empty)
+import Data.Set (Set)
 
 -- $intro
 --
@@ -151,6 +152,7 @@
              , visible  :: [Screen i a sid sd]     -- ^ non-focused workspaces, visible in xinerama
              , hidden   :: [Workspace i a]      -- ^ workspaces not visible anywhere
              , floating :: M.Map a RationalRect -- ^ floating windows
+             , windowtags :: M.Map a (Set i)    -- ^ window tags 
              } deriving (Show, Read, Eq)
 
 -- | Visible workspaces, and their Xinerama screens.
@@ -208,7 +210,7 @@
 -- Xinerama: Virtual workspaces are assigned to physical screens, starting at 0.
 --
 new :: (Integral s) => [i] -> [sd] -> StackSet i a s sd
-new wids m | not (null wids) && length m <= length wids = StackSet cur visi unseen M.empty
+new wids m | not (null wids) && length m <= length wids = StackSet cur visi unseen M.empty M.empty
   where (seen,unseen) = L.splitAt (length m) $ map (flip Workspace Nothing) wids
         (cur:visi)    = [ Screen i s sd |  (i, s, sd) <- zip3 seen [0..] m ]
                 -- now zip up visibles with their screen id
@@ -453,9 +455,16 @@
 --   * otherwise, delete doesn't affect the master.
 --
 delete :: (Ord a, Eq s) => a -> StackSet i a s sd -> StackSet i a s sd
-delete w s = s { current = removeFromScreen (current s)
-               , visible = map removeFromScreen (visible s)
-               , hidden = map removeFromWorkspace (hidden s) }
+delete w s = s' { floating = M.delete w (floating s')
+                , windowtags = M.delete w (windowtags s') }
+    where s' = deletetmp w s
+
+-- only temporarily remove the window from the stack, thereby not destroying special
+-- information saved in the Stackset
+deletetmp :: (Ord a, Eq s) => a -> StackSet i a s sd -> StackSet i a s sd
+deletetmp w s = s { current = removeFromScreen (current s)
+                  , visible = map removeFromScreen (visible s)
+                  , hidden = map removeFromWorkspace (hidden s) }
     where removeFromWorkspace ws = ws { stack = stack ws >>= filter (/=w) }
           removeFromScreen scr = scr { workspace = removeFromWorkspace (workspace scr) }
 
@@ -495,5 +504,5 @@
 shift :: (Ord a, Eq s, Eq i) => i -> StackSet i a s sd -> StackSet i a s sd
 shift n s | n `tagMember` s && n /= curtag = maybe s go (peek s)
           | otherwise                      = s
-    where go w = view curtag . insertUp w . view n . delete w $ s
+    where go w = view curtag . insertUp w . view n . deletetmp w $ s
           curtag = tag (workspace (current s))


TagWindows.hs

-----------------------------------------------------------------------------
-- |
-- Module       : XMonadContrib.TagWindows
-- Copyright    : (c) Karsten Schoelzel <kuser at gmx.de>
-- License      : BSD
--
-- Maintainer   : Karsten Schoelzel <kuser at gmx.de>
-- Stability    : unstable
-- Portability  : unportable
--
-- Functions for tagging windows and selecting them by tags.
-----------------------------------------------------------------------------

module XMonadContrib.TagWindows (
                 -- * Usage
                 -- $usage
                 addTag, delTag, 
                 withTagged,  withTaggedGlobal , withFocusedX,
                 withTaggedM, withTaggedGlobalM,
                 focusTaggedUp,
                 shiftX, shiftHere
                 ) where

import Data.Set (Set)
import qualified Data.Set as Set
--import Data.Map (Map)
import qualified Data.Map as Map
import Data.List (intersect)

import Control.Monad.State ( gets )
import StackSet hiding (filter)
import Operations (windows)

import Graphics.X11.Xlib
import XMonad

-- $usage

-- a -> i -> StackSet i a s sd -> StackSet i a s sd
getTags :: (Ord a) => a -> StackSet i a s sd -> Maybe (Set i)
getTags w s = Map.lookup w (windowtags s)

addTag :: (Ord a, Ord i) => i -> a -> i -> StackSet i a s sd -> StackSet i a s sd
addTag t w _ s = s { windowtags = Map.insertWith (Set.union) w (Set.singleton t) (windowtags s) }

delTag :: (Ord a, Ord i) => i -> a -> i -> StackSet i a s sd -> StackSet i a s sd
delTag t w _ s = s { windowtags = Map.update (\x -> Just (Set.delete t x)) w (windowtags s) }

hasTag :: (Ord a, Ord i) => i -> a -> StackSet i a s sd -> Bool
hasTag t w s = case getTags w s of
    Nothing -> False
    (Just ts) -> Set.member t ts

focusTaggedUp :: WorkspaceId -> X ()
focusTaggedUp t = windows (focusTaggedUp' t)

focusTaggedUp' :: (Ord a, Eq s, Eq i, Ord i) => i -> StackSet i a s sd -> StackSet i a s sd
focusTaggedUp' ta s | wt == []   = s
                    | otherwise  = modify' (focusUpWith (`elem` wt)) s
    where
        tagwins = Map.keys (Map.filter (Set.member ta) (windowtags s))
        wt = (integrate' . stack . workspace . current $ s) `intersect` tagwins
        
focusUpWith :: (a -> Bool) -> Stack a -> Stack a
focusUpWith f (Stack t (l:ls) rs) = if f l then s else focusUpWith f s where s = Stack l ls (t:rs)
focusUpWith f (Stack t []     rs) = if f x then s else focusUpWith f s 
    where
        s = Stack x xs []
        (x:xs) = reverse (t:rs)


withTagged :: WorkspaceId -> (Window -> WorkspaceId -> WindowSet -> WindowSet) -> X ()
withTagged t f = do
    wset <- gets windowset
    let wspace = workspace . current $ wset
        taggedWins = filter (\w -> hasTag t w wset) (integrate' . stack $ wspace) 
    case taggedWins of
        [] -> return ()
        _  -> windows $ foldl1 (.) (map (\w -> f w (tag wspace)) taggedWins)

withTaggedM :: WorkspaceId -> (Window -> X ()) -> X ()
withTaggedM t f = do
    wset <- gets windowset
    let wspace = workspace . current $ wset
        taggedWins = filter (\w -> hasTag t w wset) (integrate' . stack $ wspace) 
    mapM_ f taggedWins

withTaggedGlobal :: WorkspaceId -> (Window -> WorkspaceId -> WindowSet -> WindowSet) -> X ()
withTaggedGlobal t f = do
    wset <- gets windowset
    let wspaces = workspaces wset
        wins = concat $ map (\ws -> map (\w -> (w,tag ws)) (integrate' . stack $ ws)) wspaces
        taggedWins = filter (\(w,_) -> hasTag t w wset) wins 
    case taggedWins of
        [] -> return ()
        _  -> windows $ foldl1 (.) (map (\(w,tt) -> f w tt) taggedWins)

withTaggedGlobalM :: WorkspaceId -> (Window -> X ()) -> X ()
withTaggedGlobalM t f = do
    tags <- gets (Map.toList . windowtags . windowset)
    let taggedWins = map (fst) $ (filter (\(_,wts) -> t `Set.member` wts) tags)
    mapM_ f taggedWins


withFocusedX :: (Window -> WorkspaceId -> WindowSet -> WindowSet) -> X ()
withFocusedX f = do 
    wset <- gets windowset
    let curtag = tag . workspace . current $ wset
    maybe (return ()) (\w -> windows (f w curtag)) (peek wset)

shiftX :: (Ord a, Eq s, Eq i) => i -> a -> i -> StackSet i a s sd -> StackSet i a s sd
shiftX to w from s | from `tagMember` s && to `tagMember` s && to /= from = go w
                   | otherwise                                            = s
    where go w' = view curtag . insertUp w' . view to . deletetmp w' . view from $ s
          curtag = tag (workspace (current s))

shiftHere :: (Ord a, Eq s, Eq i) => a -> i -> StackSet i a s sd -> StackSet i a s sd
shiftHere w from s = shiftX (tag . workspace . current $ s) w from s