From 387613b2f0752836524ccd6d9d8001694bd219fb Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Tue, 19 Jul 2011 12:25:08 +0200 Subject: Gracefully shut down systray --- lib/Phi/Phi.hs | 2 +- lib/Phi/Widgets/Systray.hs | 94 +++++++++++++++++++++++++++------------------- lib/Phi/Widgets/Taskbar.hs | 2 +- lib/Phi/X11.hs | 47 +++++++++++++++++++++-- phi.cabal | 4 +- 5 files changed, 103 insertions(+), 46 deletions(-) diff --git a/lib/Phi/Phi.hs b/lib/Phi/Phi.hs index f7cf4c7..94655d4 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 | 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 diff --git a/lib/Phi/Widgets/Systray.hs b/lib/Phi/Widgets/Systray.hs index 3d3c38b..e11e58d 100644 --- a/lib/Phi/Widgets/Systray.hs +++ b/lib/Phi/Widgets/Systray.hs @@ -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 [] - - 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 + 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 xembedWindow + _ -> + case (fromMessage m) of + Just (RenderIcon midParent window x y w h reset) -> do + errorWindowRef <- liftIO $ newIORef [] - errorWindows <- liftIO $ readIORef errorWindowRef - mapM_ (removeIcon phi disp) errorWindows - _ -> - return () + 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) + + (_, x', y', w', h', _, _) <- getGeometry disp midParent + let resize = (fromIntegral x) /= x' || (fromIntegral y) /= y' || (fromIntegral w) /= w' || (fromIntegral h) /= h' + + when resize $ do + moveResizeWindow disp midParent (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) + resizeWindow disp window (fromIntegral w) (fromIntegral h) + sync disp False + + clearArea disp midParent 0 0 (fromIntegral w) (fromIntegral h) True + sync disp False + + 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 () diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/Taskbar.hs index f8b61f0..24f6611 100644 --- a/lib/Phi/Widgets/Taskbar.hs +++ b/lib/Phi/Widgets/Taskbar.hs @@ -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 diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs index 0da8594..9bd5cd4 100644 --- a/lib/Phi/X11.hs +++ b/lib/Phi/X11.hs @@ -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 diff --git a/phi.cabal b/phi.cabal index 72a14b4..d5b59c8 100644 --- a/phi.cabal +++ b/phi.cabal @@ -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 -- cgit v1.2.3