1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
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
|
