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
|
{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-}
module Phi.Widgets.Taskbar ( TaskbarConfig(..)
, defaultTaskbarConfig
, taskbar
) where
import Control.Concurrent
import Control.Monad
import Control.Monad.State
import Control.Monad.Trans
import Data.Char
import Data.Maybe
import Data.Typeable
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.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
data TaskbarConfig = TaskbarConfig { taskMaxSize :: !Int
, showDesktops :: !Bool
, taskBorder :: !BorderConfig
, activeTaskBorder :: !BorderConfig
} deriving Show
defaultTaskbarConfig :: TaskbarConfig
defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 150
, showDesktops = False
, taskBorder = defaultBorderConfig
, activeTaskBorder = defaultBorderConfig { borderColor = (1, 1, 1, 1) }
}
data Taskbar = Taskbar TaskbarConfig deriving Show
data TaskbarState = TaskbarState { taskbarActiveWindow :: !Window
, taskbarDesktopCount :: !Int
, taskbarWindows :: ![Window]
, taskbarWindowStates :: !(M.Map Window WindowState)
} deriving Show
data WindowState = WindowState { windowTitle :: !String
, windowDesktop :: !Int
, windowVisible :: !Bool
} deriving (Show, Eq)
data TaskbarMessage = WindowListUpdate [Xlib.Window] (M.Map Window WindowState)
| 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
minSize _ = 0
weight _ = 1
render (Taskbar config) TaskbarState {taskbarActiveWindow = activeWindow, taskbarDesktopCount = desktopCount, taskbarWindows = windows, taskbarWindowStates = windowStates} 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 border = if window == activeWindow then activeTaskBorder config else taskBorder config
drawBorder border (i*windowWidth) 0 windowWidth h
handleMessage _ priv m = case (fromMessage m) of
Just (WindowListUpdate windows windowStates) -> priv {taskbarWindows = windows, taskbarWindowStates = windowStates}
Just (DesktopCountUpdate count) -> priv {taskbarDesktopCount = count}
Just (ActiveWindowUpdate window) -> priv {taskbarActiveWindow = window}
_ -> priv
windowOnDesktop :: Int -> WindowState -> Bool
windowOnDesktop desktop state = (windowVisible state) && (desktop == windowDesktop state)
taskbarRunner :: Phi -> Display -> IO ()
taskbarRunner phi dispvar = do
(windows, tasks) <- liftIO $ withDisplay dispvar $ \disp -> do
(windows, tasks) <- getWindowStates disp (getAtoms dispvar) [] M.empty
desktopCount <- getDesktopCount disp (getAtoms dispvar)
activeWindow <- getActiveWindow disp (getAtoms dispvar)
sendMessage phi $ WindowListUpdate windows tasks
sendMessage phi $ DesktopCountUpdate desktopCount
sendMessage phi $ ActiveWindowUpdate activeWindow
return (windows, tasks)
sendMessage phi Repaint
flip evalStateT (windows, tasks) $ 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) 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_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) <- get
(windows', windowStates') <- liftIO $ getWindowStates disp atoms windows windowStates
when (windows /= windows' || windowStates /= windowStates') $ do
sendMessage phi $ WindowListUpdate windows' windowStates'
sendMessage phi Repaint
put (windows', windowStates')
else do
(windows, windowStates) <- get
when (elem window windows) $ 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'
sendMessage phi Repaint
put (windows, windowStates')
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 -> IO ([Window], M.Map Window WindowState)
getWindowStates disp atoms oldWindows windowStates = do
windows <- getWindowList disp atoms oldWindows
let windowStates' = map (\w -> (w, M.lookup w windowStates)) windows
newWindowStates <- mapM getWindowState' windowStates'
return (windows, M.fromList newWindowStates)
where
rootwin = Xlib.defaultRootWindow disp
getWindowState' (window, Just windowState) = return (window, windowState)
getWindowState' (window, Nothing) = do
windowState <- getWindowState disp atoms window
return (window, windowState)
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))
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
|
