summaryrefslogtreecommitdiffstats
path: root/lib/Phi/Widgets
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Phi/Widgets')
-rw-r--r--lib/Phi/Widgets/Systray.hs163
1 files changed, 145 insertions, 18 deletions
diff --git a/lib/Phi/Widgets/Systray.hs b/lib/Phi/Widgets/Systray.hs
index e1ab198..3d3c38b 100644
--- a/lib/Phi/Widgets/Systray.hs
+++ b/lib/Phi/Widgets/Systray.hs
@@ -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 <?>"
+
+instance Show Phi where
+ show _ = "Phi <?>"
+
+instance Show (IORef a) where
+ show _ = "IORef <?>"
+
-data SystrayState = SystrayState Rectangle [SystrayIconState] deriving Show
+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