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,7 +92,10 @@ 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
+      sendMessage phi HoldShutdown
+      
+      forever $ do
         m <- receiveMessage phi
         case (fromMessage m) of
           Just event ->
@@ -103,7 +106,7 @@ systrayRunner phi dispvar = do
                 errorWindowRef <- liftIO $ newIORef []
                 
                 withDisplay dispvar $ \disp -> do
-                liftIO $ do
+                  liftIO $ flip catch (\_ -> return ()) $ do
                     sync disp False
                     setErrorHandler $ \disp eventptr -> do
                       event <- getErrorEvent eventptr
@@ -111,24 +114,35 @@ systrayRunner phi dispvar = do
                         errorWindows <- readIORef errorWindowRef
                         writeIORef errorWindowRef (ev_resourceid event:errorWindows)
                     
-                (_, x', y', w', h', _, _) <- liftIO $ getGeometry disp midParent
+                    (_, x', y', w', h', _, _) <- getGeometry disp midParent
                     let resize = (fromIntegral x) /= x' || (fromIntegral y) /= y' || (fromIntegral w) /= w' || (fromIntegral h) /= h'
                     
-                when resize $ liftIO $ do
+                    when resize $ do
                       moveResizeWindow disp midParent (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h)
                       resizeWindow disp window (fromIntegral w) (fromIntegral h)
-                  liftIO $ sync disp False
+                      sync disp False
                     
-                when (resize || reset) $ liftIO $ do
                     clearArea disp midParent 0 0 (fromIntegral w) (fromIntegral h) True
-                  liftIO $ sync disp False
+                    sync disp False
-                  clearArea disp window 0 0 (fromIntegral w) (fromIntegral h) True
-                  liftIO $ sync disp False
                       
-                liftIO $ xSetErrorHandler
+                    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 ->
@@ -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
@@ -38,6 +40,8 @@ data XConfig = XConfig { phiXScreenInfo :: !(Display -> IO [Rectangle])
 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,8 +131,29 @@ 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'}

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