neocturne/phi
Archived
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Gracefully shut down systray

Browse source
This commit is contained in:
Matthias Schiffer 2011-07-19 12:25:08 +02:00
parent 19c4bb3521
commit 387613b2f0
5 changed files with 103 additions and 46 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
lib/Phi/Phi.hs
View file

@ -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 | ResetBackground deriving (Typeable, Show)
data DefaultMessage = Repaint | ResetBackground | Shutdown | HoldShutdown | ReleaseShutdown deriving (Typeable, Show)
fromMessage :: (Typeable a, Show a) => Message -> Maybe a
fromMessage (Message m) = cast m

84
lib/Phi/Widgets/Systray.hs
View file

@ -92,45 +92,59 @@ systrayRunner phi dispvar = do
initSuccess <- withDisplay dispvar $ flip initSystray atoms
case initSuccess of
Just xembedWindow -> flip evalStateT M.empty $ forever $ do
m <- receiveMessage phi
case (fromMessage m) of
Just event ->
handleEvent event phi dispvar xembedWindow
_ ->
case (fromMessage m) of
Just (RenderIcon midParent window x y w h reset) -> do
errorWindowRef <- liftIO $ newIORef []
Just xembedWindow -> flip evalStateT M.empty $ do
sendMessage phi HoldShutdown
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)
forever $ do
m <- receiveMessage phi
case (fromMessage m) of
Just event ->
handleEvent event phi dispvar xembedWindow
_ ->
case (fromMessage m) of
Just (RenderIcon midParent window x y w h reset) -> do
errorWindowRef <- liftIO $ newIORef []
(_, x', y', w', h', _, _) <- liftIO $ getGeometry disp midParent
let resize = (fromIntegral x) /= x' || (fromIntegral y) /= y' || (fromIntegral w) /= w' || (fromIntegral h) /= h'
withDisplay dispvar $ \disp -> do
liftIO $ flip catch (\_ -> return ()) $ 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)
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
(_, x', y', w', h', _, _) <- getGeometry disp midParent
let resize = (fromIntegral x) /= x' || (fromIntegral y) /= y' || (fromIntegral w) /= w' || (fromIntegral h) /= h'
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
when resize $ do
moveResizeWindow disp midParent (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)
resizeWindow disp window (fromIntegral w) (fromIntegral h)
sync disp False
liftIO $ xSetErrorHandler
clearArea disp midParent 0 0 (fromIntegral w) (fromIntegral h) True
sync disp False
errorWindows <- liftIO $ readIORef errorWindowRef
mapM_ (removeIcon phi disp) errorWindows
_ ->
return ()
when (resize || reset) $ do
clearArea disp window 0 0 (fromIntegral w) (fromIntegral h) True
sync disp False
xSetErrorHandler
errorWindows <- liftIO $ readIORef errorWindowRef
mapM_ (removeIcon phi disp) errorWindows
_ ->
case (fromMessage m) of
Just Shutdown -> do
windows <- gets M.keys
withDisplay dispvar $ \disp -> do
mapM_ (removeIcon phi disp) windows
liftIO $ do
destroyWindow disp xembedWindow
sync disp False
sendMessage phi ReleaseShutdown
_ ->
return ()
Nothing ->
return ()
@ -265,8 +279,12 @@ removeIcon phi disp window = do
sendMessage phi $ RemoveIcon window
sendMessage phi Repaint
liftIO $ do
selectInput disp window $ noEventMask
unmapWindow disp window
reparentWindow disp window (defaultRootWindow disp) 0 0
destroyWindow disp midParent
sync disp False
modify $ M.delete window
_ ->
return ()

2
lib/Phi/Widgets/Taskbar.hs
View file

@ -530,7 +530,7 @@ premultiply c = a .|. r .|. g .|. b
getWindowScreen :: Xlib.Display -> [Xlib.Rectangle] -> Window -> IO Xlib.Rectangle
getWindowScreen disp screens window = do
getWindowScreen disp screens window = flip catch (\_ -> return $ head screens) $ do
(_, _, _, width, height, _, _) <- Xlib.getGeometry disp window
(ret, x, y, _) <- Xlib.translateCoordinates disp window (Xlib.defaultRootWindow disp) 0 0

47
lib/Phi/X11.hs
View file

@ -22,6 +22,8 @@ import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Trans
import System.Exit
import System.Posix.Signals
import System.Posix.Types
import Phi.Phi
@ -35,9 +37,11 @@ import qualified Phi.Bindings.Util as Util
data XConfig = XConfig { phiXScreenInfo :: !(Display -> IO [Rectangle])
}
data PhiState = PhiState { phiRootImage :: !Surface
, phiPanels :: ![PanelState]
, phiRepaint :: !Bool
data PhiState = PhiState { phiRootImage :: !Surface
, phiPanels :: ![PanelState]
, phiRepaint :: !Bool
, phiShutdown :: !Bool
, phiShutdownHold :: !Int
}
data PanelState = PanelState { panelWindow :: !Window
@ -74,13 +78,27 @@ runPhi xconfig config widgets = do
xSetErrorHandler
phi <- initPhi
installHandler sigTERM (termHandler phi) Nothing
installHandler sigINT (termHandler phi) Nothing
installHandler sigQUIT (termHandler phi) Nothing
disp <- openDisplay []
atoms <- initAtoms disp
selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask
bg <- createImageSurface FormatRGB24 1 1
runPhiX PhiConfig { phiPhi = phi, phiXConfig = xconfig, phiPanelConfig = config, phiAtoms = atoms } PhiState { phiRootImage = bg, phiPanels = [], phiRepaint = True } $ do
runPhiX PhiConfig { phiPhi = phi
, phiXConfig = xconfig
, phiPanelConfig = config
, phiAtoms = atoms
} PhiState { phiRootImage = bg
, phiPanels = []
, phiRepaint = True
, phiShutdown = False
, phiShutdownHold = 0
} $ do
updateRootImage disp
screens <- liftIO $ phiXScreenInfo xconfig disp
@ -113,9 +131,30 @@ runPhi xconfig config widgets = do
message <- receiveMessage phi
handleMessage dispvar message
case (fromMessage message) of
Just Shutdown ->
modify $ \state -> state { phiShutdown = True }
Just HoldShutdown ->
modify $ \state -> state { phiShutdownHold = phiShutdownHold state + 1 }
Just ReleaseShutdown ->
modify $ \state -> state { phiShutdownHold = phiShutdownHold state - 1 }
_ ->
return ()
shutdown <- gets phiShutdown
shutdownHold <- gets phiShutdownHold
when (shutdown && (shutdownHold == 0)) $
liftIO $ exitSuccess
return ()
termHandler :: Phi -> Handler
termHandler phi = Catch $ sendMessage phi Shutdown
handlePanel :: Message -> PanelState -> PanelState
handlePanel message panel@PanelState {panelWidgetStates = widgets} = panel {panelWidgetStates = widgets'}
where

4
phi.cabal
View file

@ -11,14 +11,14 @@ maintainer: mschiffer@universe-factory.net
build-type: Simple
library
build-depends: base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, X11, cairo, pango
build-depends: base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, X11, cairo, pango, unix
exposed-modules: Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11,
Phi.Widgets.AlphaBox, Phi.Widgets.Clock, Phi.Widgets.Taskbar, Phi.Widgets.Systray
other-modules: Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.Util
hs-source-dirs: lib
extra-libraries: X11
pkgconfig-depends: cairo >= 1.2.0, cairo-xlib
--ghc-options: -fspec-constr-count=16 -threaded
ghc-options: -fspec-constr-count=16 -threaded
executable Phi
build-depends: base >= 4, phi