summaryrefslogtreecommitdiffstats
path: root/lib/Phi
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Phi')
-rw-r--r--lib/Phi/Phi.hs2
-rw-r--r--lib/Phi/Widgets/Systray.hs94
-rw-r--r--lib/Phi/Widgets/Taskbar.hs2
-rw-r--r--lib/Phi/X11.hs47
4 files changed, 101 insertions, 44 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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-21 19:27:11 +0100