Gracefully shut down systray
This commit is contained in:
parent
19c4bb3521
commit
387613b2f0
5 changed files with 103 additions and 46 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
clearArea disp window 0 0 (fromIntegral w) (fromIntegral h) True
|
||||
liftIO $ sync disp False
|
||||
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 ()
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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'}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Reference in a new issue