282 lines
10 KiB
Haskell
282 lines
10 KiB
Haskell
{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-}
|
|
|
|
module Phi.Widgets.X11.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 SystrayState) where
|
|
initWidget (Systray) phi dispvar screens = do
|
|
phi' <- dupPhi phi
|
|
forkIO $ systrayRunner phi' dispvar $ snd . head $ screens
|
|
|
|
return $ SystrayState phi (fst . head $ screens) 0 []
|
|
|
|
initCache _ = createRenderCache $ \(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 (UpdateScreens screens) -> SystrayState phi (fst . head $ screens) reset icons
|
|
_ -> case (fromMessage m) of
|
|
Just ResetBackground -> SystrayState phi screen (reset+1) icons
|
|
_ -> priv
|
|
|
|
|
|
systrayRunner :: Phi -> Display -> Window -> IO ()
|
|
systrayRunner phi dispvar panelWindow = 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 panelWindow 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
|
|
|
|
|
|
handleEvent :: Event -> Phi -> Display -> Window -> Window -> StateT (M.Map Window Window) IO ()
|
|
handleEvent message@ClientMessageEvent { ev_message_type = message_type, ev_data = messageData, ev_window = window } phi dispvar panelWindow 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
|
|
when (iconID /= 0) $ withDisplay dispvar $ \disp -> addIcon phi disp (getAtoms dispvar) panelWindow $ 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 panelWindow xembedWindow =
|
|
withDisplay dispvar $ \disp -> removeIcon phi disp True window
|
|
|
|
handleEvent message@DestroyWindowEvent { ev_window = window } phi dispvar panelWindow xembedWindow =
|
|
withDisplay dispvar $ \disp -> removeIcon phi disp False window
|
|
|
|
handleEvent message@AnyEvent { ev_window = window } phi dispvar panelWindow 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
|