137 lines
4 KiB
Haskell
137 lines
4 KiB
Haskell
{-# 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
|