Don't redraw when there are still messages pending

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