From 8854f0aec4b882324649d3a5ce1c99e8af9862d7 Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Sat, 16 Jul 2011 13:21:24 +0200 Subject: Don't redraw when there are still messages pending --- lib/Phi/Phi.hs | 16 ++++++++++------ lib/Phi/X11.hs | 36 +++++++++++++++++++++--------------- phi.cabal | 3 ++- 3 files changed, 33 insertions(+), 22 deletions(-) diff --git a/lib/Phi/Phi.hs b/lib/Phi/Phi.hs index 3f4b59b..ab384a0 100644 --- a/lib/Phi/Phi.hs +++ b/lib/Phi/Phi.hs @@ -8,15 +8,16 @@ module Phi.Phi ( Phi , dupPhi , sendMessage , receiveMessage + , messageAvailable ) where -import Control.Concurrent.Chan +import Control.Concurrent.STM import Control.Monad import Control.Monad.IO.Class import Data.Typeable -data Phi = Phi (Chan Message) +data Phi = Phi (TChan Message) data Message = forall a. (Typeable a, Show a) => Message a deriving instance Show Message @@ -27,13 +28,16 @@ fromMessage :: (Typeable a, Show a) => Message -> Maybe a fromMessage (Message m) = cast m initPhi :: MonadIO m => m Phi -initPhi = liftM Phi $ liftIO newChan +initPhi = liftM Phi $ liftIO $ atomically newTChan dupPhi :: MonadIO m => Phi -> m Phi -dupPhi (Phi chan) = liftM Phi $ liftIO $ dupChan chan +dupPhi (Phi chan) = liftM Phi $ liftIO $ atomically $ dupTChan chan sendMessage :: (MonadIO m, Typeable a, Show a) => Phi -> a -> m () -sendMessage (Phi chan) = liftIO . writeChan chan . Message +sendMessage (Phi chan) = liftIO . atomically . writeTChan chan . Message receiveMessage :: MonadIO m => Phi -> m Message -receiveMessage (Phi chan) = liftIO $ readChan chan +receiveMessage (Phi chan) = liftIO $ atomically $ readTChan chan + +messageAvailable :: MonadIO m => Phi -> m Bool +messageAvailable (Phi chan) = liftIO $ liftM not $ atomically $ isEmptyTChan chan diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs index 3beb47e..709d04a 100644 --- a/lib/Phi/X11.hs +++ b/lib/Phi/X11.hs @@ -35,9 +35,9 @@ import qualified Phi.Bindings.Util as Util data XConfig = XConfig { phiXScreenInfo :: !(Display -> IO [Rectangle]) } -data PhiState = PhiState { phiPhi :: !Phi - , phiRootImage :: !Surface +data PhiState = PhiState { phiRootImage :: !Surface , phiPanels :: ![PanelState] + , phiRepaint :: !Bool } data PanelState = PanelState { panelWindow :: !Window @@ -47,7 +47,8 @@ data PanelState = PanelState { panelWindow :: !Window , panelWidgetStates :: ![Widget.WidgetState] } -data PhiConfig = PhiConfig { phiPanelConfig :: !Panel.PanelConfig +data PhiConfig = PhiConfig { phiPhi :: !Phi + , phiPanelConfig :: !Panel.PanelConfig , phiXConfig :: !XConfig , phiAtoms :: !Atoms } @@ -79,7 +80,7 @@ runPhi xconfig config widgets = do selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask bg <- createImageSurface FormatRGB24 1 1 - runPhiX PhiConfig { phiXConfig = xconfig, phiPanelConfig = config, phiAtoms = atoms } PhiState { phiPhi = phi, phiRootImage = bg, phiPanels = [] } $ do + runPhiX PhiConfig { phiPhi = phi, phiXConfig = xconfig, phiPanelConfig = config, phiAtoms = atoms } PhiState { phiRootImage = bg, phiPanels = [], phiRepaint = True } $ do updateRootImage disp screens <- liftIO $ phiXScreenInfo xconfig disp @@ -97,11 +98,16 @@ runPhi xconfig config widgets = do modify $ \state -> state { phiPanels = panels } - updatePanels disp True - liftIO $ forkIO $ receiveEvents phi dispvar forever $ do + available <- messageAvailable phi + unless available $ do + repaint <- gets phiRepaint + when repaint $ do + Widget.withDisplay dispvar $ flip updatePanels True + modify $ \state -> state {phiRepaint = False} + message <- receiveMessage phi handleMessage dispvar message return () @@ -117,14 +123,14 @@ handleMessage dispvar m = do modify $ \state@PhiState {phiPanels = panels} -> state {phiPanels = map (handlePanel m) panels} case (fromMessage m) of - Just Repaint -> Widget.withDisplay dispvar $ \disp -> - updatePanels disp True + Just Repaint -> + modify $ \state -> state {phiRepaint = True} _ -> case (fromMessage m) of - Just ExposeEvent {} -> Widget.withDisplay dispvar $ \disp -> - updatePanels disp False - Just event@PropertyEvent {} -> Widget.withDisplay dispvar $ \disp -> - handlePropertyUpdate disp event + Just ExposeEvent {} -> + Widget.withDisplay dispvar $ flip updatePanels False + Just event@PropertyEvent {} -> + Widget.withDisplay dispvar $ flip handlePropertyUpdate event _ -> return () @@ -187,19 +193,19 @@ updatePanels disp redraw = do handlePropertyUpdate :: Display -> Event -> PhiX () handlePropertyUpdate disp PropertyEvent { ev_atom = atom } = do + phi <- asks phiPhi atoms <- asks phiAtoms panels <- gets phiPanels when (atom == atom_XROOTPMAP_ID atoms || atom == atom_XROOTMAP_ID atoms) $ do updateRootImage disp - updatePanels disp True + sendMessage phi Repaint updateRootImage :: Display -> PhiX () updateRootImage disp = do atoms <- asks phiAtoms - let screen = defaultScreen disp visual = defaultVisual disp screen rootwin = defaultRootWindow disp @@ -228,7 +234,7 @@ updateRootImage disp = do createPanel :: Display -> [Widget.WidgetState] -> Rectangle -> PhiX PanelState createPanel disp widgets screenRect = do - phi <- gets phiPhi + phi <- asks phiPhi config <- asks phiPanelConfig let rect = panelBounds config screenRect diff --git a/phi.cabal b/phi.cabal index ea33c35..aa65df4 100644 --- a/phi.cabal +++ b/phi.cabal @@ -11,11 +11,12 @@ maintainer: mschiffer@universe-factory.net build-type: Simple library - build-depends: base >= 4, template-haskell, 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 exposed-modules: Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11, Phi.Widgets.Clock, Phi.Widgets.Taskbar other-modules: Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.Util hs-source-dirs: lib + ghc-options: -fspec-constr-count=16 executable Phi build-depends: base >= 4, phi -- cgit v1.2.3