summaryrefslogtreecommitdiffstats
path: root/lib/Phi
diff options
context:
space:
mode:
authorMatthias Schiffer <mschiffer@universe-factory.net>2011-07-19 11:16:50 +0200
committerMatthias Schiffer <mschiffer@universe-factory.net>2011-07-19 11:16:50 +0200
commit19c4bb35212b422ce0c3d8808357e0edf8728218 (patch)
tree4c6d596f730f176f802402cd9787ad661ec1f36f /lib/Phi
parent581e1f9c63101fd2a00711748415997b0c20b793 (diff)
downloadphi-19c4bb35212b422ce0c3d8808357e0edf8728218.tar
phi-19c4bb35212b422ce0c3d8808357e0edf8728218.zip
Basic systray implementation
Diffstat (limited to 'lib/Phi')
-rw-r--r--lib/Phi/Bindings/Util.hsc30
-rw-r--r--lib/Phi/Phi.hs2
-rw-r--r--lib/Phi/Widget.hs9
-rw-r--r--lib/Phi/Widgets/Systray.hs163
-rw-r--r--lib/Phi/X11.hs76
-rw-r--r--lib/Phi/X11/AtomList.hs1
6 files changed, 224 insertions, 57 deletions
diff --git a/lib/Phi/Bindings/Util.hsc b/lib/Phi/Bindings/Util.hsc
index 32737ff..bae6c71 100644
--- a/lib/Phi/Bindings/Util.hsc
+++ b/lib/Phi/Bindings/Util.hsc
@@ -3,6 +3,7 @@
module Phi.Bindings.Util ( setClassHint
, visualIDFromVisual
, putClientMessage
+ , Phi.Bindings.Util.getEvent
, createXlibSurface
) where
@@ -51,6 +52,35 @@ putClientMessage event window message_type messageData = do
foreign import ccall unsafe "cairo-xlib.h cairo_xlib_surface_create"
xlibSurfaceCreate :: Display -> Drawable -> Visual -> CInt -> CInt -> IO (Ptr Surface)
+getEvent :: Display -> XEventPtr -> IO Event
+getEvent display p = do
+ eventType <- get_EventType p
+ case True of
+ _ | eventType == clientMessage -> do
+ serial <- (#peek XClientMessageEvent, serial) p
+ send_event <- (#peek XClientMessageEvent, send_event) p
+ window <- (#peek XClientMessageEvent, window) p
+ message_type <- (#peek XClientMessageEvent, message_type) p
+ format <- (#peek XClientMessageEvent, format) p
+ let datPtr = (#ptr XClientMessageEvent, data) p
+ dat <- case (format::CInt) of
+ 8 -> do a <- peekArray 20 datPtr
+ return $ map fromIntegral (a::[CUChar])
+ 16 -> do a <- peekArray 10 datPtr
+ return $ map fromIntegral (a::[CUShort])
+ 32 -> do a <- peekArray 5 datPtr
+ return $ map fromIntegral (a::[CULong])
+ return $ ClientMessageEvent { ev_event_type = eventType
+ , ev_serial = serial
+ , ev_send_event = send_event
+ , ev_event_display = display
+ , ev_window = window
+ , ev_message_type = message_type
+ , ev_data = dat
+ }
+ | otherwise -> Graphics.X11.Xlib.Extras.getEvent p
+
+
createXlibSurface :: Display -> Drawable -> Visual -> CInt -> CInt -> IO Surface
createXlibSurface dpy drawable visual width height = do
surfacePtr <- xlibSurfaceCreate dpy drawable visual width height
diff --git a/lib/Phi/Phi.hs b/lib/Phi/Phi.hs
index ab384a0..f7cf4c7 100644
--- a/lib/Phi/Phi.hs
+++ b/lib/Phi/Phi.hs
@@ -22,7 +22,7 @@ data Phi = Phi (TChan Message)
data Message = forall a. (Typeable a, Show a) => Message a
deriving instance Show Message
-data DefaultMessage = Repaint deriving (Typeable, Show)
+data DefaultMessage = Repaint | ResetBackground deriving (Typeable, Show)
fromMessage :: (Typeable a, Show a) => Message -> Maybe a
fromMessage (Message m) = cast m
diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs
index 6a2a9f6..7bce659 100644
--- a/lib/Phi/Widget.hs
+++ b/lib/Phi/Widget.hs
@@ -3,6 +3,7 @@
module Phi.Widget ( Display(..)
, withDisplay
, getAtoms
+ , getScreenWindows
, getScreens
, unionArea
, Widget(..)
@@ -28,7 +29,7 @@ import Phi.Phi
import Phi.X11.Atoms
-data Display = Display (MVar Xlib.Display) Atoms [Xlib.Rectangle]
+data Display = Display (MVar Xlib.Display) Atoms [(Xlib.Rectangle, Xlib.Window)]
withDisplay :: MonadIO m => Display -> (Xlib.Display -> m a) -> m a
withDisplay (Display dispvar _ _) f = do
@@ -40,8 +41,12 @@ withDisplay (Display dispvar _ _) f = do
getAtoms :: Display -> Atoms
getAtoms (Display _ atoms _) = atoms
+getScreenWindows :: Display -> [(Xlib.Rectangle, Xlib.Window)]
+getScreenWindows (Display _ _ screenWindows) = screenWindows
+
getScreens :: Display -> [Xlib.Rectangle]
-getScreens (Display _ _ screens) = screens
+getScreens = map fst . getScreenWindows
+
unionArea :: Xlib.Rectangle -> Xlib.Rectangle -> Int
unionArea a b = fromIntegral $ uw*uh
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
diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs
index 3930826..0da8594 100644
--- a/lib/Phi/X11.hs
+++ b/lib/Phi/X11.hs
@@ -41,7 +41,7 @@ data PhiState = PhiState { phiRootImage :: !Surface
}
data PanelState = PanelState { panelWindow :: !Window
- , panelBuffer :: !Surface
+ , panelPixmap :: !Pixmap
, panelArea :: !Rectangle
, panelScreenArea :: !Rectangle
, panelWidgetStates :: ![Widget.WidgetState]
@@ -85,12 +85,15 @@ runPhi xconfig config widgets = do
screens <- liftIO $ phiXScreenInfo xconfig disp
+ panelWindows <- mapM (createPanelWindow disp) screens
+
dispmvar <- liftIO $ newMVar disp
- let dispvar = Widget.Display dispmvar atoms screens
+ let screenPanels = zip screens panelWindows
+ dispvar = Widget.Display dispmvar atoms screenPanels
widgetStates <- liftIO $ mapM (Widget.createWidgetState phi dispvar) widgets
Widget.withDisplay dispvar $ \disp -> do
- panels <- mapM (createPanel disp widgetStates) screens
+ panels <- mapM (\(screen, window) -> createPanel disp window widgetStates screen) screenPanels
forM_ panels $ \panel -> do
setPanelProperties disp panel
@@ -105,7 +108,7 @@ runPhi xconfig config widgets = do
unless available $ do
repaint <- gets phiRepaint
when repaint $ do
- Widget.withDisplay dispvar $ flip updatePanels True
+ updatePanels dispvar
modify $ \state -> state {phiRepaint = False}
message <- receiveMessage phi
@@ -127,8 +130,6 @@ handleMessage dispvar m = do
modify $ \state -> state {phiRepaint = True}
_ ->
case (fromMessage m) of
- Just ExposeEvent {} ->
- Widget.withDisplay dispvar $ flip updatePanels False
Just event@PropertyEvent {} ->
Widget.withDisplay dispvar $ flip handlePropertyUpdate event
_ ->
@@ -144,7 +145,7 @@ receiveEvents phi dispvar = do
if pend /= 0 then
do
liftIO $ nextEvent disp xevent
- event <- liftIO $ getEvent xevent
+ event <- liftIO $ Util.getEvent disp xevent
sendMessage phi event
return True
@@ -152,18 +153,23 @@ receiveEvents phi dispvar = do
when (not handled) $ threadWaitRead connection
-updatePanels :: Display -> Bool -> PhiX ()
-updatePanels disp redraw = do
+updatePanels :: Widget.Display -> PhiX ()
+updatePanels dispvar = do
rootImage <- gets phiRootImage
panels <- gets phiPanels
panels' <- forM panels $ \panel -> do
- let buffer = panelBuffer panel
+ let pixmap = panelPixmap panel
area = panelArea panel
- newPanel <- if not redraw then return panel else do
- let layoutedWidgets = (withDimension area $ Widget.layoutWidgets (panelWidgetStates panel) 0 0) $ panelScreenArea panel
- panel' = panel { panelWidgetStates = layoutedWidgets }
+ let layoutedWidgets = (withDimension area $ Widget.layoutWidgets (panelWidgetStates panel) 0 0) $ panelScreenArea panel
+ panel' = panel { panelWidgetStates = layoutedWidgets }
+
+ Widget.withDisplay dispvar $ \disp -> do
+ let screen = defaultScreen disp
+ visual = defaultVisual disp screen
+
+ buffer <- liftIO $ withDimension area $ Util.createXlibSurface disp pixmap visual
renderWith buffer $ do
withPatternForSurface rootImage $ \pattern -> do
@@ -174,20 +180,16 @@ updatePanels disp redraw = do
restore
Widget.renderWidgets layoutedWidgets $ panelScreenArea panel
- return panel'
-
- let screen = defaultScreen disp
- visual = defaultVisual disp screen
- surface <- liftIO $ withDimension area $ Util.createXlibSurface disp (panelWindow newPanel) visual
-
- -- copy buffer to window
- renderWith surface $ withPatternForSurface buffer $ \pattern -> do
- setSource pattern
- paint
- surfaceFinish surface
+ surfaceFinish buffer
+
+ -- copy buffer to window
+ liftIO $ do
+ setWindowBackgroundPixmap disp (panelWindow panel') pixmap
+ (withDimension area $ clearArea disp (panelWindow panel') 0 0) True
+ sync disp False
- return newPanel
-
+ return panel'
+
modify $ \state -> state { phiPanels = panels' }
@@ -199,6 +201,7 @@ handlePropertyUpdate disp PropertyEvent { ev_atom = atom } = do
when (atom == atom_XROOTPMAP_ID atoms || atom == atom_XROOTMAP_ID atoms) $ do
updateRootImage disp
+ sendMessage phi ResetBackground
sendMessage phi Repaint
@@ -232,26 +235,27 @@ updateRootImage disp = do
surfaceFinish rootSurface
-createPanel :: Display -> [Widget.WidgetState] -> Rectangle -> PhiX PanelState
-createPanel disp widgets screenRect = do
- phi <- asks phiPhi
+createPanel :: Display -> Window -> [Widget.WidgetState] -> Rectangle -> PhiX PanelState
+createPanel disp win widgets screenRect = do
config <- asks phiPanelConfig
let rect = panelBounds config screenRect
-
- win <- createPanelWindow disp rect
-
- buffer <- liftIO $ withDimension rect $ createImageSurface FormatRGB24
+ let screen = defaultScreen disp
+ depth = defaultDepth disp screen
+
+ pixmap <- liftIO $ (withDimension rect $ createPixmap disp win) depth
return PanelState { panelWindow = win
- , panelBuffer = buffer
+ , panelPixmap = pixmap
, panelArea = rect
, panelScreenArea = screenRect
, panelWidgetStates = widgets
}
createPanelWindow :: Display -> Rectangle -> PhiX Window
-createPanelWindow disp rect = do
- let screen = defaultScreen disp
+createPanelWindow disp screenRect = do
+ config <- asks phiPanelConfig
+ let rect = panelBounds config screenRect
+ screen = defaultScreen disp
depth = defaultDepth disp screen
visual = defaultVisual disp screen
colormap = defaultColormap disp screen
diff --git a/lib/Phi/X11/AtomList.hs b/lib/Phi/X11/AtomList.hs
index b91ae3e..535a252 100644
--- a/lib/Phi/X11/AtomList.hs
+++ b/lib/Phi/X11/AtomList.hs
@@ -37,6 +37,7 @@ atoms = [ "UTF8_STRING"
, "_NET_CURRENT_DESKTOP"
, "_NET_CLIENT_LIST"
, "_MOTIF_WM_HINTS"
+ , "_XEMBED"
, "_XROOTPMAP_ID"
, "_XROOTMAP_ID"
]