blob: 26ff0a43c6c978cd9c4c2197630bbe89788c64a0 (
plain)
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
|
{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-}
module Phi.Widgets.Systray ( systray
) where
import Control.Concurrent
import Control.Monad
import Data.Maybe
import Foreign.C.Types
import Graphics.X11.Xlib hiding (Display)
import qualified Graphics.X11.Xlib as Xlib
import Graphics.X11.Xlib.Extras
import Phi.Bindings.Util
import Phi.Phi
import Phi.Types
import Phi.Widget
import Phi.X11.Atoms
data SystrayIconState = SystrayIconState deriving Show
data SystrayState = SystrayState [SystrayIconState] deriving Show
data Systray = Systray deriving Show
instance WidgetClass Systray where
type WidgetData Systray = SystrayState
initWidget (Systray) phi dispvar = do
forkIO $ systrayRunner phi dispvar
return $ SystrayState []
minSize _ (SystrayState icons) height = (length icons)*height
weight _ = 0
render Systray (SystrayState icons) w h screen = do
return ()
systrayRunner :: Phi -> Display -> IO ()
systrayRunner phi dispvar = do
let atoms = getAtoms dispvar
initSuccess <- withDisplay dispvar $ flip initSystray atoms
case initSuccess of
Just xembedWindow -> forever $ do
m <- receiveMessage phi
case (fromMessage m) of
Just event ->
handleEvent event phi dispvar xembedWindow
_ ->
return ()
Nothing ->
return ()
initSystray :: Xlib.Display -> Atoms -> IO (Maybe Window)
initSystray disp atoms = do
currentSystrayWin <- xGetSelectionOwner disp $ atom_NET_SYSTEM_TRAY_SCREEN atoms
if currentSystrayWin /= 0 then do
pid <- liftM (fromMaybe "" . fmap (\pid -> " (pid" ++ show (fromIntegral pid :: CUShort) ++ ")") . join . fmap listToMaybe) $
getWindowProperty16 disp (atom_NET_WM_PID atoms) currentSystrayWin
putStrLn $ "Phi: another systray is running." ++ pid
return Nothing
else do
xembedWin <- createSimpleWindow disp (defaultRootWindow disp) (-1) (-1) 1 1 0 0 0
-- orient horizontally
changeProperty32 disp xembedWin (atom_NET_SYSTEM_TRAY_ORIENTATION atoms) cARDINAL propModeReplace [0]
-- set visual
let rootwin = defaultRootWindow disp
screen = defaultScreen disp
visual = defaultVisual disp screen
visualID = visualIDFromVisual visual
changeProperty32 disp xembedWin (atom_NET_SYSTEM_TRAY_VISUAL atoms) vISUALID propModeReplace [fromIntegral visualID]
xSetSelectionOwner disp (atom_NET_SYSTEM_TRAY_SCREEN atoms) xembedWin currentTime
systrayWin <- xGetSelectionOwner disp $ atom_NET_SYSTEM_TRAY_SCREEN atoms
if systrayWin /= xembedWin then do
destroyWindow disp xembedWin
putStrLn $ "Phi: can't initialize systray."
return Nothing
else do
allocaXEvent $ \event -> do
putClientMessage event rootwin (atomMANAGER atoms) [fromIntegral currentTime, fromIntegral (atom_NET_SYSTEM_TRAY_SCREEN atoms), fromIntegral xembedWin, 0, 0]
sendEvent disp rootwin False structureNotifyMask event
return $ Just xembedWin
sYSTEM_TRAY_REQUEST_DOCK :: CInt
sYSTEM_TRAY_REQUEST_DOCK = 0
sYSTEM_TRAY_BEGIN_MESSAGE :: CInt
sYSTEM_TRAY_BEGIN_MESSAGE = 1
sYSTEM_TRAY_CANCEL_MESSAGE :: CInt
sYSTEM_TRAY_CANCEL_MESSAGE = 2
handleEvent :: Event -> Phi -> Display -> Window -> IO ()
handleEvent ClientMessageEvent { ev_message_type = message_type, ev_data = messageData, ev_window = window } phi dispvar xembedWindow = do
let atoms = getAtoms dispvar
when (window == xembedWindow && message_type == atom_NET_SYSTEM_TRAY_OPCODE atoms) $ do
case messageData of
(_:opcode:iconID:_) -> do
case True of
_ | opcode == sYSTEM_TRAY_REQUEST_DOCK -> do
return ()
| opcode == sYSTEM_TRAY_BEGIN_MESSAGE || opcode == sYSTEM_TRAY_CANCEL_MESSAGE -> do
return ()
| otherwise -> do
return ()
_ ->
return ()
handleEvent _ _ _ _ = return ()
systray :: Widget
systray = Widget $ Systray
|
