Gracefully shut down systray

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

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
+    Just xembedWindow -> flip evalStateT M.empty $ do
-      m <- receiveMessage phi
+      sendMessage phi HoldShutdown
-      case (fromMessage m) of
+      
-        Just event ->
+      forever $ do
-          handleEvent event phi dispvar xembedWindow
+        m <- receiveMessage phi
-        _ ->
+        case (fromMessage m) of
-          case (fromMessage m) of
+          Just event ->
-            Just (RenderIcon midParent window x y w h reset) -> do
+            handleEvent event phi dispvar xembedWindow
-              errorWindowRef <- liftIO $ newIORef []
+          _ ->
-              
+            case (fromMessage m) of
-              withDisplay dispvar $ \disp -> do
+              Just (RenderIcon midParent window x y w h reset) -> do
-                liftIO $ do
+                errorWindowRef <- liftIO $ newIORef []
-                  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
+                withDisplay dispvar $ \disp -> do
-                  moveResizeWindow disp midParent (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)
+                  liftIO $ flip catch (\_ -> return ()) $ do
-                  resizeWindow disp window (fromIntegral w) (fromIntegral h)
+                    sync disp False
-                  liftIO $ sync disp False
+                    setErrorHandler $ \disp eventptr -> do
-                
+                      event <- getErrorEvent eventptr
-                when (resize || reset) $ liftIO $ do
+                      when (ev_error_code event == fromIntegral badWindow) $ do
-                  clearArea disp midParent 0 0 (fromIntegral w) (fromIntegral h) True
+                        errorWindows <- readIORef errorWindowRef
-                  liftIO $ sync disp False
+                        writeIORef errorWindowRef (ev_resourceid event:errorWindows)
-                  clearArea disp window 0 0 (fromIntegral w) (fromIntegral h) True
+                    
-                  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'
-                liftIO $ xSetErrorHandler
+                    
-                
+                    when resize $ do
-                errorWindows <- liftIO $ readIORef errorWindowRef
+                      moveResizeWindow disp midParent (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)
-                mapM_ (removeIcon phi disp) errorWindows
+                      resizeWindow disp window (fromIntegral w) (fromIntegral h)
-            _ ->
+                      sync disp False
-              return ()
+                    
+                    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 ()
 

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
   

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
+data PhiState = PhiState { phiRootImage    :: !Surface
-                         , phiPanels     :: ![PanelState]
+                         , phiPanels       :: ![PanelState]
-                         , phiRepaint    :: !Bool
+                         , 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

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