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
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
|
-----------------------------------------------------------------------------
-- |
-- Module : XMonad.Actions.GridSelect
-- Copyright : Clemens Fruhwirth <clemens@endorphin.org>
-- License : BSD-style (see LICENSE)
--
-- Maintainer : Clemens Fruhwirth <clemens@endorphin.org>
-- Stability : unstable
-- Portability : unportable
--
-- GridSelect displays a 2D grid of windows to navigate with cursor
-- keys and to select with return.
--
-----------------------------------------------------------------------------
module XMonad.Actions.GridSelect (
-- * Usage
-- $usage
GSConfig(..),
defaultGSConfig,
gridselect,
withSelectedWindow,
bringSelected,
goToSelected
) where
import Data.Maybe
import Data.Bits
import Control.Monad.State
import Control.Arrow
import Data.List as L
import XMonad
import XMonad.Util.Font
import XMonad.Prompt (mkUnmanagedWindow)
import XMonad.StackSet as W
import XMonad.Layout.Decoration
import XMonad.Util.NamedWindows
import XMonad.Actions.WindowBringer (bringWindow)
import Text.Printf
-- $usage
--
-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
--
-- > import XMonad.Actions.GridSelect
--
-- Then add a keybinding, e.g.
--
-- > , ((modMask x, xK_g), goToSelected defaultGSConfig)
--
-- Screenshot: <http://clemens.endorphin.org/gridselect.png>
data GSConfig = GSConfig {
gs_cellheight :: Integer,
gs_cellwidth :: Integer,
gs_cellpadding :: Integer,
gs_colorizer :: Window -> Bool -> X (String, String),
gs_font :: String
}
type TwoDPosition = (Integer, Integer)
data TwoDState = TwoDState { td_curpos :: TwoDPosition,
td_windowmap :: [(TwoDPosition,(String,Window))],
td_gsconfig :: GSConfig,
td_font :: XMonadFont,
td_paneX :: Integer,
td_paneY :: Integer }
type TwoD a = StateT TwoDState X a
diamondLayer :: (Enum b', Num b') => b' -> [(b', b')]
-- FIXME remove nub
diamondLayer n = let ul = [ (x,n-x) | x <- [0..n] ]
in nub $ ul ++ (map (negate *** id) ul) ++
(map (negate *** negate) ul) ++
(map (id *** negate) ul)
diamond :: (Enum a, Num a) => [(a, a)]
diamond = concatMap diamondLayer [0..]
diamondRestrict :: (Enum t, Num t, Ord t) => t -> t -> [(t, t)]
diamondRestrict x y = L.filter (\(x',y') -> abs x' <= x && abs y' <= y) .
L.takeWhile (\(x',y') -> abs x' + abs y' <= x+y) $ diamond
tupadd :: (Num t1, Num t) => (t, t1) -> (t, t1) -> (t, t1)
tupadd (a,b) (c,d) = (a+c,b+d)
tupmul :: (Num t1, Num t) => (t, t1) -> (t, t1) -> (t, t1)
tupmul (a,b) (c,d) = (a*c,b*d)
drawWinBox :: Display -> Window -> XMonadFont -> (String, String) -> Integer -> Integer -> String -> Integer -> Integer -> Integer -> X ()
drawWinBox dpy win font (fg,bg) ch cw text x y cp = do
gc <- liftIO $ createGC dpy win
bordergc <- liftIO $ createGC dpy win
liftIO $ do
Just fgcolor <- initColor dpy fg
Just bgcolor <- initColor dpy bg
Just bordercolor <- initColor dpy borderColor
setForeground dpy gc fgcolor
setBackground dpy gc bgcolor
setForeground dpy bordergc bordercolor
fillRectangle dpy win gc (fromInteger x) (fromInteger y) (fromInteger cw) (fromInteger ch)
drawRectangle dpy win bordergc (fromInteger x) (fromInteger y) (fromInteger cw) (fromInteger ch)
stext <- shrinkWhile (shrinkIt shrinkText)
(\n -> do size <- liftIO $ textWidthXMF dpy font n
return $ size > (fromInteger (cw-(2*cp))))
text
printStringXMF dpy win font gc bg fg (fromInteger (x+cp)) (fromInteger (y+(div ch 2))) stext
liftIO $ freeGC dpy gc
liftIO $ freeGC dpy bordergc
updateWindows :: Display -> Window -> TwoD ()
updateWindows dpy win = do
(TwoDState curpos windowList gsconfig font paneX paneY) <- get
let cellwidth = gs_cellwidth gsconfig
cellheight = gs_cellheight gsconfig
paneX' = div (paneX-cellwidth) 2
paneY' = div (paneY-cellheight) 2
updateWindow (pos@(x,y),(text, clientwindow)) = lift $ do
colors <- (gs_colorizer gsconfig) clientwindow (pos == curpos)
drawWinBox dpy win font
colors
(gs_cellheight gsconfig)
(gs_cellwidth gsconfig) text
(paneX'+x*cellwidth)
(paneY'+y*cellheight)
(gs_cellpadding gsconfig)
mapM updateWindow windowList
return ()
eventLoop :: Display -> Window -> TwoD (Maybe Window)
eventLoop d win = do
(keysym,string,event) <- liftIO $ allocaXEvent $ \e -> do
nextEvent d e
ev <- getEvent e
(ks,s) <- if ev_event_type ev == keyPress
then lookupString $ asKeyEvent e
else return (Nothing, "")
return (ks,s,ev)
handle d win (fromMaybe xK_VoidSymbol keysym,string) event
handle :: Display
-> Window
-> (KeySym, String)
-> Event
-> StateT TwoDState X (Maybe Window)
handle d win (ks,_) (KeyEvent {ev_event_type = t})
| t == keyPress && ks == xK_Escape = return Nothing
| t == keyPress && ks == xK_Left = diffAndRefresh (-1,0)
| t == keyPress && ks == xK_Right = diffAndRefresh (1,0)
| t == keyPress && ks == xK_Down = diffAndRefresh (0,1)
| t == keyPress && ks == xK_Up = diffAndRefresh (0,-1)
| t == keyPress && ks == xK_Return = do
(TwoDState pos win' _ _ _ _) <- get
return $ fmap (snd . snd) $ find ((== pos) . fst) win'
where diffAndRefresh diff = do
(TwoDState pos windowmap gsconfig font paneX paneY) <- get
let newpos = pos `tupadd` diff
when (isJust $ find ((newpos ==).fst) windowmap) $ do
put $ TwoDState newpos windowmap gsconfig font paneX paneY
updateWindows d win
eventLoop d win
handle d win _ _ = do
updateWindows d win
eventLoop d win
-- FIXME probably move that into Utils?
-- Conversion scheme as in http://en.wikipedia.org/wiki/HSV_color_space
hsv2rgb :: Fractional a => (Integer,a,a) -> (a,a,a)
hsv2rgb (h,s,v) =
let hi = (div h 60) `mod` 6 :: Integer
f = (((fromInteger h)/60) - (fromInteger hi)) :: Fractional a => a
q = v * (1-f)
p = v * (1-s)
t = v * (1-(1-f)*s)
in case hi of
0 -> (v,t,p)
1 -> (q,v,p)
2 -> (p,v,t)
3 -> (p,q,v)
4 -> (t,p,v)
5 -> (v,p,q)
_ -> error "The world is ending. x mod a >= a."
default_colorizer :: Window -> Bool -> X (String, String)
default_colorizer w active = do
classname <- runQuery className w
let seed x = toInteger (sum $ map ((*x).fromEnum) classname) :: Integer
(r,g,b) = hsv2rgb ((seed 83) `mod` 360,
(fromInteger ((seed 191) `mod` 1000))/2500+0.4,
(fromInteger ((seed 121) `mod` 1000))/2500+0.4)
if active
then return ("#faff69", "black")
else return ("#" ++ concat (map (twodigitHex.(round :: Double -> Integer).(*256)) [r, g, b] ), "white")
where
twodigitHex :: Integer -> String
twodigitHex a = printf "%02x" a
-- | Brings up a 2D grid of windows in the center of the screen, and one can
-- select a window with cursors keys. The selected window is returned.
gridselect :: GSConfig -> X (Maybe Window)
gridselect gsconfig =
withDisplay $ \dpy -> do
rootw <- liftIO $ rootWindow dpy (defaultScreen dpy)
s <- gets $ screenRect . W.screenDetail . W.current . windowset
windowList <- windowMap
win <- liftIO $ mkUnmanagedWindow dpy (defaultScreenOfDisplay dpy) rootw
(rect_x s) (rect_y s) (rect_width s) (rect_height s)
liftIO $ mapWindow dpy win
liftIO $ selectInput dpy win (exposureMask .|. keyPressMask)
status <- io $ grabKeyboard dpy win True grabModeAsync grabModeAsync currentTime
font <- initXMF (gs_font gsconfig)
let screenWidth = toInteger $ rect_width s;
screenHeight = toInteger $ rect_height s;
selectedWindow <- if (status == grabSuccess) then
do
let restrictX = floor $ ((fromInteger screenWidth)/(fromInteger $ gs_cellwidth gsconfig)-1)/2 ;
restrictY = floor $ ((fromInteger screenHeight)/(fromInteger $ gs_cellheight gsconfig)-1)/2 ;
selectedWindow <- evalStateT (do updateWindows dpy win; eventLoop dpy win)
(TwoDState (0,0)
(zipWith (,) (diamondRestrict restrictX restrictY) windowList)
gsconfig
font
screenWidth
screenHeight)
return selectedWindow
else
return Nothing
liftIO $ do
unmapWindow dpy win
destroyWindow dpy win
sync dpy False
releaseXMF font
return selectedWindow
-- | Brings up a 2D grid of windows in the center of the screen, and one can
-- select a window with cursors keys. The selected window is then passed to
-- a callback function.
withSelectedWindow :: (Window -> X ()) -> GSConfig -> X ()
withSelectedWindow callback conf = do
mbWindow <- gridselect conf
case mbWindow of
Just w -> callback w
Nothing -> return ()
windowMap :: X [(String,Window)]
windowMap = do
ws <- gets windowset
wins <- mapM keyValuePair (W.allWindows ws)
return wins
where keyValuePair w = flip (,) w `fmap` decorateName' w
decorateName' :: Window -> X String
decorateName' w = do
fmap show $ getName w
defaultGSConfig :: GSConfig
defaultGSConfig = GSConfig 50 130 10 default_colorizer "xft:Sans-8"
borderColor :: String
borderColor = "white"
-- | Brings selected window to the current workspace.
bringSelected :: GSConfig -> X ()
bringSelected = withSelectedWindow $ \w -> do
windows (bringWindow w)
XMonad.focus w
windows W.shiftMaster
-- | Switches to selected window's workspace and focuses that window.
goToSelected :: GSConfig -> X ()
goToSelected = withSelectedWindow $ windows . W.focusWindow
|