[Xmonad] Window tags (automagic) + assign workspace to windows on startup

Karsten Schoelzel kuser at gmx.de
Sat Sep 8 10:45:33 EDT 2007


On Sat, Sep 08, 2007 at 01:03:57AM +0200, Karsten Schoelzel wrote:
> 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 :-))
> 
Hi,

extending the patch with automagic-tagging and automagic-moving of
on window start

  This patch needs changes to the core of xmonad to work,
  but most work is done is in the TagWindows module:
  - add/delete tags
  - automatically adding tags on window creation based on window class, name, command
  - use tags for automagically assigning workspaces to windows (including floating status)
      * adding a tag "~" makes the window floating initially
      * adding a existing workspace id will move the window to workspace with that id,
          e.g. adding "2" will move the window to the second workspace
  - change focus restricted to a group of windows with a specified tag,
      either only on the current workspace or globally
  
The two rules in tagMatches below state:
  - tag every window with WM_CLASS = gimp with the tags "2" and "~",
        thus moving them to workspace "2" and float them
  - tag every xterm window which has "screen" as an argument gets with
    "abc"

As it is a bit invasive I'd like to hear your comments.

Regards,
Karsten

diff -rN -u old-xmonad/Config.hs new-xmonad/Config.hs
@@ -120,6 +133,20 @@
 logHook = return ()
 
 -- |
+-- Perform an arbitrary action on window manage event.
+--
+manageHook :: Window -> X (Bool)
+manageHook = tagManageHook tagMatches
+--manageHook = do \_ -> return (False)
+
+tagMatches :: [TagMatch]
+tagMatches = [ 
+                defaultTM { tmclass = ("gimp" `elem`), tmtags = ["2", "~"] }
+             ,  defaultTM { tmcommand = ("screen" `elem`), tmclass = ("xterm" `elem`), tmtags = ["abc"] }
+             ]
+
+-- Examples include:
+-- |
 -- The key bindings list.
 -- 
 -- The unusual comment format is used to generate the documentation
@@ -152,6 +180,17 @@
     , ((modMask,               xK_l     ), sendMessage Expand) -- @@ Expand the master area
 
     , ((modMask,               xK_t     ), withFocused sink) -- @@ Push window back into tiling
+    , ((modMask,               xK_f     ), withFocusedX (addTag "abc")) 
+    , ((modMask .|. controlMask, xK_f     ), withFocusedX (delTag "abc")) 
+    , ((modMask .|. shiftMask, xK_f     ), withTaggedGlobalM "abc" sink) 
+    , ((modWinMask,            xK_f     ), withTagged "abc" (shiftX "2")) 
+    , ((modWinMask .|. shiftMask, xK_f  ), withTaggedGlobal "abc" shiftHere) 
+    , ((modWinMask .|. controlMask, xK_f  ), focusTaggedUpGlobal "abc") 
 
     -- increase or decrease number of windows in the master area
     , ((modMask              , xK_comma ), sendMessage (IncMasterN 1)) -- @@ Increment the number of windows in the master area
diff -rN -u old-xmonad/Config.hs-boot new-xmonad/Config.hs-boot
--- old-xmonad/Config.hs-boot	2007-09-08 16:32:04.000000000 +0200
+++ new-xmonad/Config.hs-boot	2007-09-08 16:32:04.000000000 +0200
@@ -1,8 +1,9 @@
 module Config where
 import Graphics.X11.Xlib.Types (Dimension)
-import Graphics.X11.Xlib (KeyMask)
+import Graphics.X11.Xlib (KeyMask,Window)
 import XMonad
 borderWidth :: Dimension
 logHook     :: X ()
+manageHook  :: Window -> X (Bool)
 numlockMask :: KeyMask
 workspaces :: [WorkspaceId]
diff -rN -u old-xmonad/Operations.hs new-xmonad/Operations.hs
--- old-xmonad/Operations.hs	2007-09-08 16:32:04.000000000 +0200
+++ new-xmonad/Operations.hs	2007-09-08 16:32:04.000000000 +0200
@@ -18,7 +18,7 @@
 
 import XMonad
 import qualified StackSet as W
-import {-# SOURCE #-} Config (borderWidth,logHook,numlockMask)
+import {-# SOURCE #-} Config (borderWidth,logHook,manageHook,numlockMask)
 
 import Data.Maybe
 import Data.List            (nub, (\\), find)
@@ -49,19 +49,23 @@
 --
 manage :: Window -> X ()
 manage w = whenX (fmap not $ isClient w) $ withDisplay $ \d -> do
-    setInitialProperties w >> reveal w
 
     -- FIXME: This is pretty awkward. We can't can't let "refresh" happen
     -- before the call to float, because that will resize the window and
     -- lose the default sizing.
-
-    sh <- io $ getWMNormalHints d w
-    let isFixedSize = sh_min_size sh /= Nothing && sh_min_size sh == sh_max_size sh
-    isTransient <- isJust `liftM` io (getTransientForHint d w)
-    if isFixedSize || isTransient
-        then do modify $ \s -> s { windowset = W.insertUp w (windowset s) }
-                float w -- \^^ now go the refresh.
-        else windows $ W.insertUp w
+    
+    managed <- manageHook w
+    if not managed
+        then do 
+                setInitialProperties w >> reveal w
+                sh <- io $ getWMNormalHints d w
+                let isFixedSize = sh_min_size sh /= Nothing && sh_min_size sh == sh_max_size sh
+                isTransient <- isJust `liftM` io (getTransientForHint d w)
+                if isFixedSize || isTransient
+                    then do modify $ \s -> s { windowset = W.insertUp w (windowset s) }
+                            float w -- \^^ now go the refresh.
+                    else windows $ W.insertUp w
+        else return ()
 
 -- | unmanage. A window no longer exists, remove it from the window
 -- list, on whatever workspace it is.
diff -rN -u old-xmonad/StackSet.hs new-xmonad/StackSet.hs
--- old-xmonad/StackSet.hs	2007-09-08 16:32:04.000000000 +0200
+++ new-xmonad/StackSet.hs	2007-09-08 16:32:04.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))



Sat Sep  8 16:15:07 CEST 2007  Karsten Schoelzel <kuser at gmx.de>
  * TagWindows (windows tagging and managing)
  
  This patch needs changes to the core of xmonad to work,
  but most work is done is in the TagWindows module:
  - add/delete tags
  - automatically adding tags on window creation based on window class, name, command
  - use tags for automagically assigning workspaces to windows (including floating status)
      * adding a tag "~" makes the window floating initially
      * adding a existing workspace id will move the window to workspace with that id,
          e.g. adding "2" will move the window to the second workspace
  - change focus restricted to a group of windows with a specified tag,
      either only on the current workspace or globally
  
  TODO: cleanup + docs 
diff -rN -u old-XMonadContrib/MetaModule.hs new-XMonadContrib/MetaModule.hs
--- old-XMonadContrib/MetaModule.hs	2007-09-08 16:32:12.000000000 +0200
+++ new-XMonadContrib/MetaModule.hs	2007-09-08 16:32:12.000000000 +0200
@@ -64,6 +64,7 @@
 import XMonadContrib.Submap ()
 import XMonadContrib.SwitchTrans ()
 import XMonadContrib.Tabbed ()
+import XMonadContrib.TagWindows ()
 import XMonadContrib.ThreeColumns ()
 import XMonadContrib.TwoPane ()
 import XMonadContrib.ViewPrev ()
diff -rN -u old-XMonadContrib/TagWindows.hs new-XMonadContrib/TagWindows.hs
--- old-XMonadContrib/TagWindows.hs	1970-01-01 01:00:00.000000000 +0100
+++ new-XMonadContrib/TagWindows.hs	2007-09-08 16:32:12.000000000 +0200
@@ -0,0 +1,196 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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, focusTaggedUpGlobal,
+                 shiftX, shiftHere,
+                 tagManageHook, TagMatch (..), defaultTM
+                 ) where
+
+import Data.Char (chr)
+import Data.Set (Set)
+import qualified Data.Set as Set
+--import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.List (intersect,sortBy,find)
+import Data.Maybe (maybeToList,listToMaybe,isJust)
+
+import Control.Monad.State ( gets, liftM, modify )
+import StackSet hiding (filter, modify, float)
+import Operations (windows, float, setInitialProperties, reveal)
+
+import Graphics.X11.Xlib
+import Graphics.X11.Xlib.Extras
+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
+        
+focusTaggedUpGlobal :: WorkspaceId -> X ()
+focusTaggedUpGlobal t = windows (focusTaggedUpGlobal' t)
+
+focusTaggedUpGlobal' :: (Ord a, Eq s, Eq i, Ord i) => i -> StackSet i a s sd -> StackSet i a s sd
+focusTaggedUpGlobal' ta s | tagwins == []                    = s
+                          | tagwins == maybeToList (peek s)  = s
+                          | otherwise  = case ff of
+                                            Nothing       -> s
+                                            Just (fw, fn) -> (focusWindow fw) . (view fn) $ s
+    where
+        curtag = tag . workspace . current $ s
+        tagwins = Map.keys (Map.filter (Set.member ta) (windowtags s))
+        cls = maybe [] (\(Stack _ ls _) -> pairtag curtag          ls ) (stack . workspace . current $ s)
+        crs = maybe [] (\(Stack _ _ rs) -> pairtag curtag (reverse rs)) (stack . workspace . current $ s)
+        lws = map pairmap . sortByTag . filter (\w -> tag w < curtag) . workspaces $ s
+        rws = map pairmap . sortByTag . filter (\w -> tag w > curtag) . workspaces $ s
+        ff = find (\(x,_) -> x `elem` tagwins ) (concat ([cls] ++ lws ++ rws ++ [crs]))
+        pairtag t = map (\x -> (x, t))
+        pairmap w = pairtag (tag w) (reverse . integrate' . stack $ w)
+        sortByTag = sortBy (\x y -> compare (tag y) (tag x))
+        
+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
+
+data TagMatch = 
+    TagMatch { tmname    :: [String] -> Bool
+             , tmcommand :: [String] -> Bool
+             , tmclass   :: [String] -> Bool
+             , tmtags     :: [WorkspaceId]
+             } 
+
+defaultTM :: TagMatch
+defaultTM = TagMatch (const True) (const True) (const True) []
+
+tagManageHook :: [TagMatch] -> Window -> X (Bool)
+tagManageHook tms w = withDisplay $ \d -> do
+    setInitialProperties w >> reveal w
+    
+    let getprop p = io $ catch (getTextProperty d w p >>= wcTextPropertyToTextList d) (\_ -> return [[]])
+    xname     <- getprop wM_NAME
+    xcommand' <- getprop wM_COMMAND
+    xclass    <- getprop wM_CLASS 
+    let xcommand = concat . map splitAtNull $ xcommand'
+        matchTags tm = do
+            if and [ tmname tm $ xname, tmcommand tm $ xcommand, tmclass tm $ xclass ]
+                then applyTags w (tmtags tm)
+                else return ()
+    mapM_ matchTags tms
+
+    wset <- gets windowset
+    sh <- io $ getWMNormalHints d w
+    let isFixedSize = sh_min_size sh /= Nothing && sh_min_size sh == sh_max_size sh
+    isTransient <- isJust `liftM` io (getTransientForHint d w)
+    if isFixedSize || isTransient || (hasTag "~" w wset)
+        then do modify $ \s -> s { windowset = insertUp w (windowset s) }
+                float w -- \^^ now go the refresh.
+        else windows $ insertUp w
+    case getWS w wset of
+        Nothing  -> return ()
+        (Just t) -> windows $ shiftX t w (tag . workspace . current $ wset)
+    return True
+
+getWS :: (Ord a, Eq s, Eq i) => a -> StackSet i a s sd -> Maybe i
+getWS w wset = maybe Nothing insx' (getTags w wset)
+    where insx' ts = listToMaybe $ (Set.toList ts) `intersect` (map tag . workspaces $ wset) 
+         
+
+applyTags :: Window -> [WorkspaceId] -> X ()
+applyTags _ [] = return ()
+applyTags w ts = do modify $ \s -> s { windowset = (foldl1 (.) (map (\t -> addTag t w []) ts)) $ windowset s }
+
+splitAtNull :: String -> [String]
+splitAtNull s = case dropWhile (== (chr 0)) s of
+    "" -> []
+    s' -> w : splitAtNull s''
+          where (w, s'') = break (== (chr 0)) s'



More information about the Xmonad mailing list