summaryrefslogtreecommitdiffstats
path: root/lib/Phi/Widgets/Systray.hs
blob: 2aef713814811bf4bbde9bb5f240f561b685024b (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
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
{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-}

module Phi.Widgets.Systray ( systray
                           ) where

import Control.Concurrent
import Control.Monad
import Control.Monad.State
import Control.Monad.Trans

import Data.Bits
import Data.IORef
import Data.Maybe
import Data.Typeable
import qualified Data.Map as M

import Foreign.C.Types
import Foreign.Marshal
import Foreign.Ptr
import Foreign.Storable

import Graphics.Rendering.Cairo
import Graphics.Rendering.Cairo.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.Bindings.SystrayErrorHandler

import Phi.Phi
import Phi.Types
import Phi.Widget
import Phi.X11.Atoms


data SystrayIconState = SystrayIconState !Window !Window deriving (Show, Eq)

instance Eq Phi where
  _ == _ = True

data SystrayState = SystrayState !Phi !Rectangle !Int ![SystrayIconState] deriving Eq

data Systray = Systray deriving (Show, Eq)

data SystrayMessage = AddIcon !Window !Window | RemoveIcon !Window | RenderIcon !Window !Window !Int !Int !Int !Int
                      deriving (Show, Typeable)


instance Widget Systray SystrayState (RenderCache Systray SystrayState) where
  initWidget (Systray) phi dispvar = do
    phi' <- dupPhi phi
    forkIO $ systrayRunner phi' dispvar
    
    return $ SystrayState phi (head . getScreens $ dispvar) 0 []
  
  initCache _ = createRenderCache $ \Systray (SystrayState phi systrayScreen reset icons) x y w h screen -> do
    when (screen == systrayScreen) $ do
      forM_ (zip [0..] icons) $ \(i, SystrayIconState midParent window) -> do
        let x' = x + i*(h+2)
        sendMessage phi $ RenderIcon midParent window x' y h h
    
    setOperator OperatorClear
    paint
  
  minSize _ (SystrayState _ systrayScreen _ icons) height screen = case True of 
    _ | screen == systrayScreen -> max 0 $ (length icons)*(height+2)-1
      | otherwise -> 0

  weight _ = 0
  
  render = renderCached

  
  handleMessage _ priv@(SystrayState phi screen reset icons) m = case (fromMessage m) of
    Just (AddIcon midParent window) -> SystrayState phi screen reset ((SystrayIconState midParent window):icons)
    Just (RemoveIcon window) -> SystrayState phi screen reset $ filter (\(SystrayIconState _ stateWindow) -> stateWindow /= window) icons
    _ -> case (fromMessage m) of
      Just ResetBackground -> SystrayState phi screen (reset+1) icons
      _ ->  priv


systrayRunner :: Phi -> Display -> IO ()
systrayRunner phi dispvar = do
  let atoms = getAtoms dispvar
  initSuccess <- withDisplay dispvar $ flip initSystray atoms
  
  case initSuccess of
    Just xembedWindow -> flip evalStateT M.empty $ do
      sendMessage phi HoldShutdown
      
      forever $ do
        m <- receiveMessage phi
        case (fromMessage m) of
          Just event ->
            handleEvent event phi dispvar xembedWindow
          _ ->
            case (fromMessage m) of
              Just (RenderIcon midParent window x y w h) -> do
                withDisplay dispvar $ \disp -> do
                  liftIO $ flip catch (\_ -> return ()) $ do
                    sync disp False
                    setSystrayErrorHandler
                    
                    (_, x', y', w', h', _, _) <- getGeometry disp midParent
                    (_, x'', y'', w'', h'', _, _) <- getGeometry disp window
                    let resize = (fromIntegral x) /= x' || (fromIntegral y) /= y' || (fromIntegral w) /= w' || (fromIntegral h) /= h'
                                 || 0 /= x'' || 0 /= y'' || (fromIntegral w) /= w'' || (fromIntegral h) /= h''
                    
                    when resize $ do
                      moveResizeWindow disp midParent (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)
                      moveResizeWindow disp window 0 0 (fromIntegral w) (fromIntegral h)
                      sync disp False
                    
                    clearArea disp window 0 0 (fromIntegral w) (fromIntegral h) True
                      
                    sync disp False
                    xSetErrorHandler
                  
                  lastErrorWindow <- liftIO $ getLastErrorWindow
                  when (lastErrorWindow == window) $ do
                    removeIcon phi disp True window
              _ ->
                case (fromMessage m) of
                  Just Shutdown -> do
                    windows <- gets M.keys
                    withDisplay dispvar $ \disp -> do
                      mapM_ (removeIcon phi disp True) windows
                      liftIO $ do
                        destroyWindow disp xembedWindow
                        sync disp False
                      sendMessage phi ReleaseShutdown
                  _ ->
                    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

xEMBED_EMBEDDED_NOTIFY :: CInt
xEMBED_EMBEDDED_NOTIFY = 0

handleEvent :: Event -> Phi -> Display -> Window -> StateT (M.Map Window Window) IO ()
handleEvent message@ClientMessageEvent { ev_message_type = message_type, ev_data = messageData, ev_window = window } phi dispvar xembedWindow = do
  let atoms = getAtoms dispvar
      screenWindows = getScreenWindows 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
            when (iconID /= 0) $ withDisplay dispvar $ \disp -> addIcon phi disp (getAtoms dispvar) (snd . head $ screenWindows) $ fromIntegral iconID
          
            | opcode == sYSTEM_TRAY_BEGIN_MESSAGE || opcode == sYSTEM_TRAY_CANCEL_MESSAGE ->
            return ()
            
            | otherwise -> do
            liftIO $ putStrLn "Phi: unknown tray message"
            return ()
        
          
      _ ->
        return ()

handleEvent message@UnmapEvent { ev_window = window } phi dispvar xembedWindow =
  withDisplay dispvar $ \disp -> removeIcon phi disp True window

handleEvent message@DestroyWindowEvent { ev_window = window } phi dispvar xembedWindow =
  withDisplay dispvar $ \disp -> removeIcon phi disp False window

handleEvent message@AnyEvent { ev_window = window } phi dispvar xembedWindow | ev_event_type message == reparentNotify = do
  parent <- liftIO $ alloca $ \rootPtr -> alloca $ \parentPtr -> alloca $ \childrenPtrPtr -> alloca $ \nChildrenPtr -> do
    status <- withDisplay dispvar $ \disp -> xQueryTree disp window rootPtr parentPtr childrenPtrPtr nChildrenPtr
    case status of
      0 ->
        return 0
      _ -> do
        childrenPtr <- peek childrenPtrPtr
        when (childrenPtr /= nullPtr) $
          xFree childrenPtr >> return ()
        peek parentPtr
  midParent <- gets $ M.lookup window
  when (midParent /= Just parent) $
    withDisplay dispvar $ \disp -> removeIcon phi disp False window
  return ()

handleEvent _ _ _ _ = return ()


addIcon :: Phi -> Xlib.Display -> Atoms -> Window -> Window -> StateT (M.Map Window Window) IO ()
addIcon phi disp atoms panelWindow window = do
  removeIcon phi disp False window
  
  liftIO $ selectInput disp window $ structureNotifyMask .|. propertyChangeMask
  
  midParent <- liftIO $ createSimpleWindow disp panelWindow (-16) (-16) 16 16 0 0 0
  
  liftIO $ do
    setWindowBackgroundPixmap disp midParent 1 -- ParentRelative
    
    sync disp False
    setSystrayErrorHandler
    
    reparentWindow disp window midParent 0 0
    
    mapRaised disp midParent
    mapWindow disp window
    
    allocaXEvent $ \event -> do
      putClientMessage event window (atom_XEMBED atoms) [fromIntegral currentTime, fromIntegral xEMBED_EMBEDDED_NOTIFY, 0, fromIntegral midParent, 0]
      sendEvent disp window False 0xFFFFFF event
    
    sync disp False
    xSetErrorHandler
  
  errorWindow <- liftIO $ getLastErrorWindow
  case True of
    _ | errorWindow /= window -> do
      sendMessage phi $ AddIcon midParent window
      sendMessage phi Repaint
      modify $ M.insert window midParent
      | otherwise ->
      liftIO $ destroyWindow disp midParent


removeIcon :: Phi -> Xlib.Display -> Bool -> Window -> StateT (M.Map Window Window) IO ()
removeIcon phi disp reparent window = do
  mmidParent <- gets $ M.lookup window
  case mmidParent of
    Just midParent -> do
      sendMessage phi $ RemoveIcon window
      sendMessage phi Repaint
      liftIO $ do
        selectInput disp window $ noEventMask
        when reparent $
          reparentWindow disp window (defaultRootWindow disp) 0 0
        destroyWindow disp midParent
        sync disp False
      modify $ M.delete window
    _ ->
      return ()


systray :: Systray
systray = Systray