blob: f39176fee2d1c056527511c985221b5f86cc6d62 (
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
|
import Control.Concurrent
import Control.Monad
import Control.Monad.State.Strict
import Data.Word
import Data.Maybe
import Graphics.XHB
import Graphics.XHB.Connection.XCB
import Graphics.XHB.Gen.Xproto
import System.Exit
import Phi.X11.Atoms
import Phi.X11.Util
sYSTEM_TRAY_REQUEST_DOCK :: Word32
sYSTEM_TRAY_REQUEST_DOCK = 0
sYSTEM_TRAY_BEGIN_MESSAGE :: Word32
sYSTEM_TRAY_BEGIN_MESSAGE = 1
sYSTEM_TRAY_CANCEL_MESSAGE :: Word32
sYSTEM_TRAY_CANCEL_MESSAGE = 2
xEMBED_EMBEDDED_NOTIFY :: Word32
xEMBED_EMBEDDED_NOTIFY = 0
data SystrayState = SystrayState
{ systrayIcons :: [(WINDOW, WINDOW)]
}
main :: IO ()
main = do
conn <- liftM fromJust connect
forkIO $ receiveErrors conn
atoms <- initAtoms conn
let screen = (roots_Setup . connectionSetup $ conn) !! connectionScreen conn
(xembedWin, systrayWin) <- initSystray conn atoms screen
execStateT (runSystray xembedWin systrayWin) $ SystrayState []
return ()
receiveErrors :: Connection -> IO ()
receiveErrors conn =
forever $ waitForError conn >>= putStrLn . ("XHB error: " ++) . show
initSystray :: Connection -> Atoms -> SCREEN -> IO (WINDOW, WINDOW)
initSystray conn atoms screen = do
currentSystrayWin <- getSelectionOwner conn (atom_NET_SYSTEM_TRAY_SCREEN atoms) >>= getReply' "initSystray: getSelectionOwner failed"
when (currentSystrayWin /= fromXid xidNone) $ do
putStrLn "phi-systray-helper: another systray is running."
exitFailure
currentSystrayHelperWin <- getSelectionOwner conn (atomPHI_SYSTRAY_HELPER atoms) >>= getReply' "initSystray: getSelectionOwner failed"
when (currentSystrayHelperWin /= fromXid xidNone) $ do
putStrLn "phi-systray-helper: another systray helper is running."
exitFailure
let rootwin = root_SCREEN screen
depth = root_depth_SCREEN screen
visual = root_visual_SCREEN screen
xembedWin <- newResource conn
createWindow conn $ MkCreateWindow depth xembedWin rootwin (-1) (-1) 1 1 0 WindowClassInputOutput visual emptyValueParam
-- orient horizontally
changeProperty32 conn PropModeReplace xembedWin (atom_NET_SYSTEM_TRAY_ORIENTATION atoms) (atomCARDINAL atoms) [0]
-- set visual
changeProperty32 conn PropModeReplace xembedWin (atom_NET_SYSTEM_TRAY_VISUAL atoms) (atomVISUALID atoms) [fromIntegral visual]
setSelectionOwner conn $ MkSetSelectionOwner xembedWin (atom_NET_SYSTEM_TRAY_SCREEN atoms) 0
systrayWin <- getSelectionOwner conn (atom_NET_SYSTEM_TRAY_SCREEN atoms) >>= getReply' "initSystray: getSelectionOwner failed"
when (systrayWin /= xembedWin) $ do
destroyWindow conn xembedWin
putStrLn $ "phi-systray-helper: can't initialize systray."
exitFailure
systrayWin <- newResource conn
createWindow conn $ MkCreateWindow depth systrayWin rootwin (-1) (-1) 1 1 0 WindowClassInputOutput visual emptyValueParam
setSelectionOwner conn $ MkSetSelectionOwner systrayWin (atomPHI_SYSTRAY_HELPER atoms) 0
systrayHelperWin <- getSelectionOwner conn (atomPHI_SYSTRAY_HELPER atoms) >>= getReply' "initSystray: getSelectionOwner failed"
when (systrayHelperWin /= systrayWin) $ do
destroyWindow conn systrayHelperWin
destroyWindow conn xembedWin
putStrLn $ "phi-systray-helper: can't initialize systray helper."
exitFailure
sendEvent conn $ MkSendEvent False rootwin [EventMaskStructureNotify] $
serializeClientMessage $ MkClientMessageEvent 32 rootwin (atomMANAGER atoms) $
ClientData32 [0, fromXid . toXid $ atom_NET_SYSTEM_TRAY_SCREEN atoms, fromXid . toXid $ xembedWin, 0, 0]
return (xembedWin, systrayWin)
runSystray :: WINDOW -> WINDOW -> StateT SystrayState IO ()
runSystray xembedWin systrayWin = do
return ()
|
