summaryrefslogtreecommitdiffstats
path: root/lib/Phi/Widgets/Systray.hs
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