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
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
|
{-# LANGUAGE TypeFamilies, DeriveDataTypeable, TypeSynonymInstances #-}
module Phi.Widgets.Taskbar ( IconStyle
, idIconStyle
, desaturateIconStyle
, TaskStyle(..)
, TaskbarConfig(..)
, defaultTaskbarConfig
, taskbar
) where
import Control.Concurrent
import Control.Monad
import Control.Monad.State
import Control.Monad.Trans
import Data.Array.MArray
import Data.Bits
import Data.Char
import Data.Function
import Data.List
import Data.Maybe
import Data.Typeable
import Data.Word
import qualified Data.Map as M
import Foreign.C.Types
import Graphics.Rendering.Cairo
import Graphics.Rendering.Pango.Cairo
import Graphics.Rendering.Pango.Enums (PangoRectangle(..))
import Graphics.Rendering.Pango.Layout
import Graphics.Rendering.Pango.Font
import Graphics.X11.Xlib (Window)
import qualified Graphics.X11.Xlib as Xlib
import qualified Graphics.X11.Xlib.Extras as XExtras
import Codec.Binary.UTF8.String
import Phi.Phi
import Phi.Types
import Phi.Border
import Phi.Widget
import Phi.X11.Atoms
type IconStyle = Surface -> Render ()
instance Show IconStyle where
show _ = "IconStyle"
idIconStyle :: IconStyle
idIconStyle = flip withPatternForSurface setSource
desaturateIconStyle :: Double -> IconStyle
desaturateIconStyle v icon = do
w <- imageSurfaceGetWidth icon
h <- imageSurfaceGetHeight icon
renderWithSimilarSurface ContentColorAlpha w h $ \surface1 -> do
renderWithSimilarSurface ContentColor w h $ \surface2 -> do
renderWith surface1 $ do
renderWith surface2 $ do
withPatternForSurface icon setSource
paint
setOperator OperatorHslSaturation
setSourceRGBA 0 0 0 (1-v)
paint
withPatternForSurface surface2 setSource
paint
setOperator OperatorDestIn
withPatternForSurface icon setSource
paint
withPatternForSurface surface1 setSource
data TaskStyle = TaskStyle { taskFont :: !String
, taskColor :: !Color
, taskBorder :: !BorderConfig
, taskIconStyle :: !IconStyle
} deriving Show
data TaskbarConfig = TaskbarConfig { taskMaxSize :: !Int
, showDesktops :: !Bool
, normalTaskStyle :: !TaskStyle
, activeTaskStyle :: !TaskStyle
} deriving Show
defaultStyle :: TaskStyle
defaultStyle = TaskStyle { taskFont = "Sans 8"
, taskColor = (0, 0, 0, 1)
, taskBorder = defaultBorderConfig
, taskIconStyle = idIconStyle
}
defaultTaskbarConfig :: TaskbarConfig
defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 150
, showDesktops = False
, normalTaskStyle = defaultStyle
, activeTaskStyle = defaultStyle {taskBorder = defaultBorderConfig { borderColor = (1, 1, 1, 1) }}
}
data Taskbar = Taskbar TaskbarConfig deriving Show
instance Show Surface where
show _ = "Surface <?>"
data TaskbarState = TaskbarState { taskbarActiveWindow :: !Window
, taskbarDesktopCount :: !Int
, taskbarWindows :: ![Window]
, taskbarWindowStates :: !(M.Map Window WindowState)
, taskbarWindowIcons :: !(M.Map Window [(Int, Surface)])
} deriving Show
data WindowState = WindowState { windowTitle :: !String
, windowDesktop :: !Int
, windowVisible :: !Bool
} deriving (Show, Eq)
data TaskbarMessage = WindowListUpdate [Xlib.Window] (M.Map Window WindowState) (M.Map Window [(Int, Surface)])
| DesktopCountUpdate Int
| ActiveWindowUpdate Window
deriving (Show, Typeable)
instance WidgetClass Taskbar where
type WidgetData Taskbar = TaskbarState
initWidget (Taskbar _) phi dispvar = do
forkIO $ taskbarRunner phi dispvar
return $ TaskbarState 0 0 [] M.empty M.empty
minSize _ = 0
weight _ = 1
render (Taskbar config) TaskbarState { taskbarActiveWindow = activeWindow
, taskbarDesktopCount = desktopCount
, taskbarWindows = windows
, taskbarWindowStates = windowStates
, taskbarWindowIcons = windowIcons
} w h = do
let desktopWindows = map (\desktop -> (desktop, filter (fromMaybe False . fmap (windowOnDesktop desktop) . flip M.lookup windowStates) windows)) $ take desktopCount [0..]
windowCount = sum $ map (length . snd) $ desktopWindows
when (windowCount /= 0) $ do
let windowWidth = min (taskMaxSize config) (w `div` windowCount)
forM_ (zip [0..] $ join $ map snd desktopWindows) $ \(i, window) -> do
let style = (if window == activeWindow then activeTaskStyle else normalTaskStyle) config
(r, g, b, a) = taskColor style
leftBorder = (borderLeft $ margin $ taskBorder style) + (borderWidth $ taskBorder style) + (borderLeft $ padding $ taskBorder style)
rightBorder = (borderRight $ margin $ taskBorder style) + (borderWidth $ taskBorder style) + (borderRight $ padding $ taskBorder style)
h' = h - (borderV $ margin $ taskBorder style)
mstate = M.lookup window windowStates
micons = M.lookup window windowIcons
case (mstate, micons) of
(Just state, Just icons) -> do
save
drawBorder (taskBorder style) (i*windowWidth) 0 windowWidth h
clip
setSourceRGBA r g b a
renderText style (fromIntegral (i*windowWidth + leftBorder + h' + 3)) 0 (windowWidth - leftBorder - h' - 3 - rightBorder) h $ windowTitle state
restore
case bestIcon h' icons of
Just icon -> do
save
translate (fromIntegral $ i*windowWidth + leftBorder) (fromIntegral $ borderTop $ margin $ taskBorder style)
imageW <- imageSurfaceGetWidth icon
imageH <- imageSurfaceGetHeight icon
let scalef = (fromIntegral h')/(fromIntegral $ max imageW imageH)
scale scalef scalef
when (imageH < imageW) $
translate 0 $ (fromIntegral (imageW-imageH))/2
taskIconStyle style icon
paint
restore
Nothing -> return ()
_ -> return ()
handleMessage _ priv m = case (fromMessage m) of
Just (WindowListUpdate windows windowStates icons) -> priv {taskbarWindows = windows, taskbarWindowStates = windowStates, taskbarWindowIcons = icons}
Just (DesktopCountUpdate count) -> priv {taskbarDesktopCount = count}
Just (ActiveWindowUpdate window) -> priv {taskbarActiveWindow = window}
_ -> priv
renderText :: TaskStyle -> Int -> Int -> Int -> Int -> String -> Render ()
renderText style x y w h text = do
layout <- createLayout ""
(_, PangoRectangle _ _ textWidth textHeight) <- liftIO $ do
layoutSetMarkup layout $ "<span font='" ++ (taskFont style) ++ "'>" ++ (escapeMarkup text) ++ "</span>"
layoutSetWidth layout $ Just $ fromIntegral w
layoutSetEllipsize layout EllipsizeEnd
layoutGetExtents layout
moveTo ((fromIntegral x) + ((fromIntegral w) - textWidth)/2) ((fromIntegral y) + ((fromIntegral h) - textHeight)/2)
showLayout layout
bestIcon :: Int -> [(Int, Surface)] -> Maybe Surface
bestIcon h icons = findBest $ sortBy compareIcons icons
where
compareIcons = flip (compare `on` fst)
findBest (a1:a2:ax) = if (fst a2) < h then Just $ snd a1 else findBest (a2:ax)
findBest [a] = Just $ snd a
findBest [] = Nothing
windowOnDesktop :: Int -> WindowState -> Bool
windowOnDesktop desktop state = (windowVisible state) && (desktop == windowDesktop state)
taskbarRunner :: Phi -> Display -> IO ()
taskbarRunner phi dispvar = do
(windows, states, icons) <- liftIO $ withDisplay dispvar $ \disp -> do
(windows, states, icons) <- getWindowStates disp (getAtoms dispvar) [] M.empty M.empty
desktopCount <- getDesktopCount disp (getAtoms dispvar)
activeWindow <- getActiveWindow disp (getAtoms dispvar)
sendMessage phi $ WindowListUpdate windows states icons
sendMessage phi $ DesktopCountUpdate desktopCount
sendMessage phi $ ActiveWindowUpdate activeWindow
return (windows, states, icons)
sendMessage phi Repaint
flip evalStateT (windows, states, icons) $ forever $ do
m <- receiveMessage phi
case (fromMessage m) of
Just event@XExtras.PropertyEvent {} ->
handlePropertyUpdate phi dispvar event
_ ->
return ()
handlePropertyUpdate :: Phi -> Display -> XExtras.Event -> StateT ([Window], M.Map Window WindowState, M.Map Window [(Int, Surface)]) IO ()
handlePropertyUpdate phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.ev_window = window} = do
let atoms = getAtoms dispvar
when (elem atom $ map ($ atoms) [ atom_NET_ACTIVE_WINDOW
, atom_NET_NUMBER_OF_DESKTOPS
, atom_NET_CLIENT_LIST
, atom_NET_WM_ICON
, atom_NET_WM_NAME
, atomWM_NAME
, atom_NET_WM_DESKTOP
, atom_NET_WM_STATE
]) $ withDisplay dispvar $ \disp -> do
let rootwin = Xlib.defaultRootWindow disp
if (window == rootwin)
then do
when (atom == atom_NET_ACTIVE_WINDOW atoms) $ do
activeWindow <- liftIO $ getActiveWindow disp atoms
sendMessage phi $ ActiveWindowUpdate activeWindow
sendMessage phi Repaint
when (atom == atom_NET_NUMBER_OF_DESKTOPS atoms) $ do
desktopCount <- liftIO $ getDesktopCount disp atoms
sendMessage phi $ DesktopCountUpdate desktopCount
sendMessage phi Repaint
when (atom == atom_NET_CLIENT_LIST atoms) $ do
(windows, windowStates, icons) <- get
(windows', windowStates', icons') <- liftIO $ getWindowStates disp atoms windows windowStates icons
when (windows /= windows') $ do
sendMessage phi $ WindowListUpdate windows' windowStates' icons'
sendMessage phi Repaint
put (windows', windowStates', icons')
else do
(windows, windowStates, icons) <- get
when (elem window windows) $ do
when (atom == atom_NET_WM_ICON atoms) $ do
icon <- liftIO $ getWindowIcons disp atoms window
let icons' = M.insert window icon icons
sendMessage phi $ WindowListUpdate windows windowStates icons'
sendMessage phi Repaint
put (windows, windowStates, icons')
when (atom /= atom_NET_WM_ICON atoms) $ do
let windowState = M.lookup window windowStates
windowState' <- liftIO $ getWindowState disp atoms window
when (windowState /= (Just windowState')) $ do
let windowStates' = M.insert window windowState' windowStates
sendMessage phi $ WindowListUpdate windows windowStates' icons
sendMessage phi Repaint
put (windows, windowStates', icons)
getDesktopCount :: Xlib.Display -> Atoms -> IO Int
getDesktopCount disp atoms =
liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_NUMBER_OF_DESKTOPS atoms) $ Xlib.defaultRootWindow disp
getActiveWindow :: Xlib.Display -> Atoms -> IO Window
getActiveWindow disp atoms =
liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_ACTIVE_WINDOW atoms) $ Xlib.defaultRootWindow disp
getWindowStates :: Xlib.Display -> Atoms -> [Window] -> M.Map Window WindowState -> M.Map Window [(Int, Surface)]
-> IO ([Window], M.Map Window WindowState, M.Map Window [(Int, Surface)])
getWindowStates disp atoms oldWindows windowStates windowIcons = do
windows <- getWindowList disp atoms oldWindows
let windowStates' = map (\w -> (w, M.lookup w windowStates)) windows
windowIcons' = map (\w -> (w, M.lookup w windowIcons)) windows
newWindowStates <- mapM getWindowState' windowStates'
newWindowIcons <- mapM getWindowIcons' windowIcons'
return (windows, M.fromList newWindowStates, M.fromList newWindowIcons)
where
getWindowState' (window, Just windowState) = return (window, windowState)
getWindowState' (window, Nothing) = do
windowState <- getWindowState disp atoms window
return (window, windowState)
getWindowIcons' (window, Just icons) = return (window, icons)
getWindowIcons' (window, Nothing) = do
icons <- getWindowIcons disp atoms window
return (window, icons)
getWindowState :: Xlib.Display -> Atoms -> Window -> IO WindowState
getWindowState disp atoms window = do
Xlib.selectInput disp window Xlib.propertyChangeMask
netwmname <- liftM (fmap (decode . map fromIntegral)) $ XExtras.getWindowProperty8 disp (atom_NET_WM_NAME atoms) window
wmname <- case netwmname of
Just name -> return name
Nothing -> liftM (map unsignedChr . fromMaybe []) $ XExtras.getWindowProperty8 disp (atomWM_NAME atoms) window
workspace <- liftM (fromIntegral . fromMaybe 0xFFFFFFFF . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_WM_DESKTOP atoms) window
visible <- showWindow disp atoms window
return $ WindowState wmname workspace visible
where
unsignedChr = chr . fromIntegral . (fromIntegral :: (CChar -> CUChar))
getWindowIcons :: Xlib.Display -> Atoms -> Window -> IO [(Int, Surface)]
getWindowIcons disp atoms window = XExtras.getWindowProperty32 disp (atom_NET_WM_ICON atoms) window >>= readIcons . fromMaybe []
readIcons :: [CLong] -> IO [(Int, Surface)]
readIcons (width:height:iconData) = do
if ((fromIntegral $ length iconData) < (width*height)) then return [] else do
let (thisIcon, rest) = splitAt (fromIntegral (width*height)) iconData
icon <- createImageSurface FormatARGB32 (fromIntegral width) (fromIntegral height)
surfaceData <- imageSurfaceGetPixels icon :: IO (SurfaceData Int Word32)
forM_ (zip thisIcon [1..]) $ \(e, i) -> writeArray surfaceData i $ premultiply $ fromIntegral e
surfaceMarkDirty icon
moreIcons <- readIcons rest
return $ (fromIntegral $ max width height, icon):moreIcons
readIcons _ = return []
premultiply :: Word32 -> Word32
premultiply c = a .|. r .|. g .|. b
where
amask = 0xFF000000
rmask = 0x00FF0000
gmask = 0x0000FF00
bmask = 0x000000FF
a = c .&. amask
pm mask = (((c .&. mask) * (a `shiftR` 24)) `div` 0xFF) .&. mask
r = pm rmask
g = pm gmask
b = pm bmask
showWindow :: Xlib.Display -> Atoms -> Window -> IO Bool
showWindow disp atoms window = do
states <- liftM (map fromIntegral . fromMaybe []) $ XExtras.getWindowProperty32 disp (atom_NET_WM_STATE atoms) window
transientForHint <- XExtras.getTransientForHint disp window
windowType <- liftM (fromMaybe (atom_NET_WM_WINDOW_TYPE_NORMAL atoms) . fmap fromIntegral . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_WM_STATE atoms) window
return $ not $ or [ elem (atom_NET_WM_STATE_SKIP_TASKBAR atoms) states
, transientForHint /= Nothing
, elem windowType $ map ($ atoms) [ atom_NET_WM_WINDOW_TYPE_DOCK
, atom_NET_WM_WINDOW_TYPE_DESKTOP
, atom_NET_WM_WINDOW_TYPE_TOOLBAR
, atom_NET_WM_WINDOW_TYPE_MENU
, atom_NET_WM_WINDOW_TYPE_SPLASH
]
]
getWindowList :: Xlib.Display -> Atoms -> [Window] -> IO [Window]
getWindowList disp atoms windows = do
newWindows <- liftM (map fromIntegral . join . maybeToList) $ XExtras.getWindowProperty32 disp (atom_NET_CLIENT_LIST atoms) $ Xlib.defaultRootWindow disp
return $ (filter (flip elem newWindows) windows) ++ (filter (not . flip elem windows) newWindows)
taskbar :: TaskbarConfig -> Widget
taskbar config = do
Widget $ Taskbar config
|