Basic systray implementation
This commit is contained in:
parent
581e1f9c63
commit
19c4bb3521
7 changed files with 225 additions and 58 deletions
|
|
@ -5,11 +5,20 @@ module Phi.Widgets.Systray ( systray
|
|||
|
||||
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 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
|
||||
|
|
@ -22,12 +31,25 @@ import Phi.Widget
|
|||
import Phi.X11.Atoms
|
||||
|
||||
|
||||
data SystrayIconState = SystrayIconState deriving Show
|
||||
instance Show Display where
|
||||
show _ = "Display <?>"
|
||||
|
||||
data SystrayState = SystrayState Rectangle [SystrayIconState] deriving Show
|
||||
instance Show Phi where
|
||||
show _ = "Phi <?>"
|
||||
|
||||
instance Show (IORef a) where
|
||||
show _ = "IORef <?>"
|
||||
|
||||
|
||||
data SystrayIconState = SystrayIconState Window Window deriving Show
|
||||
|
||||
data SystrayState = SystrayState Phi Rectangle Int (IORef Int) [SystrayIconState] deriving Show
|
||||
|
||||
data Systray = Systray deriving Show
|
||||
|
||||
data SystrayMessage = AddIcon Window Window | RemoveIcon Window | RenderIcon Window Window Int Int Int Int Bool
|
||||
deriving (Show, Typeable)
|
||||
|
||||
|
||||
instance WidgetClass Systray where
|
||||
type WidgetData Systray = SystrayState
|
||||
|
|
@ -35,18 +57,33 @@ instance WidgetClass Systray where
|
|||
initWidget (Systray) phi dispvar = do
|
||||
forkIO $ systrayRunner phi dispvar
|
||||
|
||||
return $ SystrayState (head . getScreens $ dispvar) []
|
||||
lastReset <- newIORef 0
|
||||
return $ SystrayState phi (head . getScreens $ dispvar) 0 lastReset []
|
||||
|
||||
minSize _ (SystrayState systrayScreen icons) height screen = case True of
|
||||
minSize _ (SystrayState _ systrayScreen _ _ icons) height screen = case True of
|
||||
_ | screen == systrayScreen -> (length icons)*height
|
||||
| otherwise -> 0
|
||||
|
||||
weight _ = 0
|
||||
|
||||
render Systray (SystrayState systrayScreen icons) w h screen = case True of
|
||||
render Systray (SystrayState phi systrayScreen reset lastResetRef icons) w h screen = case True of
|
||||
_ | screen == systrayScreen -> do
|
||||
return ()
|
||||
lastReset <- liftIO $ readIORef lastResetRef
|
||||
liftIO $ writeIORef lastResetRef reset
|
||||
Matrix _ _ _ _ dx dy <- getMatrix
|
||||
forM_ (zip [0..] icons) $ \(i, SystrayIconState midParent window) -> do
|
||||
let x = round dx + i*h
|
||||
y = round dy
|
||||
sendMessage phi $ RenderIcon midParent window x y h h (lastReset /= reset)
|
||||
|
||||
| otherwise -> return ()
|
||||
|
||||
handleMessage _ priv@(SystrayState phi screen reset lastReset icons) m = case (fromMessage m) of
|
||||
Just (AddIcon midParent window) -> SystrayState phi screen reset lastReset ((SystrayIconState midParent window):icons)
|
||||
Just (RemoveIcon window) -> SystrayState phi screen reset lastReset $ filter (\(SystrayIconState _ stateWindow) -> stateWindow /= window) icons
|
||||
_ -> case (fromMessage m) of
|
||||
Just ResetBackground -> SystrayState phi screen (reset+1) lastReset icons
|
||||
_ -> priv
|
||||
|
||||
|
||||
systrayRunner :: Phi -> Display -> IO ()
|
||||
|
|
@ -55,13 +92,45 @@ systrayRunner phi dispvar = do
|
|||
initSuccess <- withDisplay dispvar $ flip initSystray atoms
|
||||
|
||||
case initSuccess of
|
||||
Just xembedWindow -> forever $ do
|
||||
Just xembedWindow -> flip evalStateT M.empty $ forever $ do
|
||||
m <- receiveMessage phi
|
||||
case (fromMessage m) of
|
||||
Just event ->
|
||||
handleEvent event phi dispvar xembedWindow
|
||||
_ ->
|
||||
return ()
|
||||
case (fromMessage m) of
|
||||
Just (RenderIcon midParent window x y w h reset) -> do
|
||||
errorWindowRef <- liftIO $ newIORef []
|
||||
|
||||
withDisplay dispvar $ \disp -> do
|
||||
liftIO $ do
|
||||
sync disp False
|
||||
setErrorHandler $ \disp eventptr -> do
|
||||
event <- getErrorEvent eventptr
|
||||
when (ev_error_code event == fromIntegral badWindow) $ do
|
||||
errorWindows <- readIORef errorWindowRef
|
||||
writeIORef errorWindowRef (ev_resourceid event:errorWindows)
|
||||
|
||||
(_, x', y', w', h', _, _) <- liftIO $ getGeometry disp midParent
|
||||
let resize = (fromIntegral x) /= x' || (fromIntegral y) /= y' || (fromIntegral w) /= w' || (fromIntegral h) /= h'
|
||||
|
||||
when resize $ liftIO $ do
|
||||
moveResizeWindow disp midParent (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)
|
||||
resizeWindow disp window (fromIntegral w) (fromIntegral h)
|
||||
liftIO $ sync disp False
|
||||
|
||||
when (resize || reset) $ liftIO $ do
|
||||
clearArea disp midParent 0 0 (fromIntegral w) (fromIntegral h) True
|
||||
liftIO $ sync disp False
|
||||
clearArea disp window 0 0 (fromIntegral w) (fromIntegral h) True
|
||||
liftIO $ sync disp False
|
||||
|
||||
liftIO $ xSetErrorHandler
|
||||
|
||||
errorWindows <- liftIO $ readIORef errorWindowRef
|
||||
mapM_ (removeIcon phi disp) errorWindows
|
||||
_ ->
|
||||
return ()
|
||||
Nothing ->
|
||||
return ()
|
||||
|
||||
|
|
@ -114,34 +183,92 @@ 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 -> IO ()
|
||||
handleEvent ClientMessageEvent { ev_message_type = message_type, ev_data = messageData, ev_window = window } phi dispvar xembedWindow = do
|
||||
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
|
||||
_:opcode:iconID:_ -> do
|
||||
case True of
|
||||
_ | opcode == sYSTEM_TRAY_REQUEST_DOCK ->
|
||||
when (iconID /= 0) $ addIcon phi dispvar $ fromIntegral iconID
|
||||
|
||||
_ | 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
|
||||
putStrLn "Phi: unknown tray message"
|
||||
liftIO $ putStrLn "Phi: unknown tray message"
|
||||
return ()
|
||||
|
||||
|
||||
_ ->
|
||||
return ()
|
||||
|
||||
handleEvent message@UnmapEvent { ev_window = window } phi dispvar xembedWindow =
|
||||
withDisplay dispvar $ flip (removeIcon phi) window
|
||||
|
||||
handleEvent message@DestroyWindowEvent { ev_window = window } phi dispvar xembedWindow =
|
||||
withDisplay dispvar $ flip (removeIcon phi) window
|
||||
|
||||
handleEvent _ _ _ _ = return ()
|
||||
|
||||
|
||||
addIcon :: Phi -> Display -> Window -> IO ()
|
||||
addIcon phi display window = do
|
||||
return ()
|
||||
addIcon :: Phi -> Xlib.Display -> Atoms -> Window -> Window -> StateT (M.Map Window Window) IO ()
|
||||
addIcon phi disp atoms panelWindow window = do
|
||||
liftIO $ selectInput disp window $ structureNotifyMask .|. propertyChangeMask
|
||||
|
||||
errorRef <- liftIO $ newIORef False
|
||||
midParent <- liftIO $ createSimpleWindow disp panelWindow (-16) (-16) 16 16 0 0 0
|
||||
|
||||
liftIO $ do
|
||||
setWindowBackgroundPixmap disp midParent 1 -- ParentRelative
|
||||
|
||||
sync disp False
|
||||
setErrorHandler $ \disp eventptr -> do
|
||||
event <- getErrorEvent eventptr
|
||||
when (ev_error_code event == fromIntegral badWindow && ev_resourceid event == window) $
|
||||
writeIORef errorRef True
|
||||
|
||||
reparentWindow disp window midParent 0 0
|
||||
sync disp False
|
||||
|
||||
mapRaised disp midParent
|
||||
mapWindow disp window
|
||||
sync disp False
|
||||
|
||||
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
|
||||
|
||||
error <- liftIO $ readIORef errorRef
|
||||
case error of
|
||||
False -> do
|
||||
sendMessage phi $ AddIcon midParent window
|
||||
sendMessage phi Repaint
|
||||
modify $ M.insert window midParent
|
||||
True ->
|
||||
liftIO $ destroyWindow disp midParent
|
||||
|
||||
|
||||
removeIcon :: Phi -> Xlib.Display -> Window -> StateT (M.Map Window Window) IO ()
|
||||
removeIcon phi disp window = do
|
||||
mmidParent <- gets $ M.lookup window
|
||||
case mmidParent of
|
||||
Just midParent -> do
|
||||
sendMessage phi $ RemoveIcon window
|
||||
sendMessage phi Repaint
|
||||
liftIO $ do
|
||||
reparentWindow disp window (defaultRootWindow disp) 0 0
|
||||
destroyWindow disp midParent
|
||||
_ ->
|
||||
return ()
|
||||
|
||||
|
||||
systray :: Widget
|
||||
|
|
|
|||
Reference in a new issue