From 579552b29b396943c3a2c97456c37c8005729ce1 Mon Sep 17 00:00:00 2001
From: Matthias Schiffer <mschiffer@universe-factory.net>
Date: Fri, 7 Oct 2011 05:31:23 +0200
Subject: Send X message batched

---
 lib/Phi/Phi.hs |  4 ++++
 lib/Phi/X11.hs | 23 ++++++++++++++++++++---
 2 files changed, 24 insertions(+), 3 deletions(-)

(limited to 'lib')

diff --git a/lib/Phi/Phi.hs b/lib/Phi/Phi.hs
index df71a1c..4a896c7 100644
--- a/lib/Phi/Phi.hs
+++ b/lib/Phi/Phi.hs
@@ -7,6 +7,7 @@ module Phi.Phi ( Phi
                , initPhi
                , dupPhi
                , sendMessage
+               , sendMessages
                , receiveMessage
                , messageAvailable
                ) where
@@ -36,6 +37,9 @@ dupPhi (Phi chan) = liftM Phi $ liftIO $ atomically $ dupTChan chan
 sendMessage :: (MonadIO m, Typeable a, Show a) => Phi -> a -> m ()
 sendMessage (Phi chan) = liftIO . atomically . writeTChan chan . Message
 
+sendMessages :: (MonadIO m, Typeable a, Show a) => Phi -> [a] -> m ()
+sendMessages (Phi chan) = liftIO . atomically . mapM_ (writeTChan chan . Message)
+
 receiveMessage :: MonadIO m => Phi -> m Message
 receiveMessage (Phi chan) = liftIO $ atomically $ readTChan chan
 
diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs
index 9c213e0..e08c990 100644
--- a/lib/Phi/X11.hs
+++ b/lib/Phi/X11.hs
@@ -179,7 +179,7 @@ runPhi xconfig config widget = do
     forever $ do
       available <- messageAvailable phi
       repaint <- gets phiRepaint
-      when (not available && repaint) $ liftIO $ threadDelay 20000
+      when (not available && repaint) $ liftIO $ threadDelay 30000
       
       available <- messageAvailable phi
       when (not available && repaint) $ do
@@ -296,9 +296,26 @@ handleConfigureNotifyEvent MkConfigureNotifyEvent { window_ConfigureNotifyEvent
       sendMessage phi $ UpdateScreens $ map (panelScreenArea &&& panelWindow) panels'
       sendMessage phi Repaint
 
+
+maybeReceiveEvents' :: Connection -> IO [XEvent]
+maybeReceiveEvents' conn = do
+  yield
+  mevent <- pollForEvent conn
+  case mevent of
+    Just event ->
+      liftM2 (:) (return . XEvent $ event) (maybeReceiveEvents' conn)
+    Nothing ->
+      return []
+      
+
+receiveEvents' :: Connection -> IO [XEvent]
+receiveEvents' conn = do
+  liftM2 (:) (liftM XEvent $ waitForEvent conn) (maybeReceiveEvents' conn)
+
+
 receiveEvents :: Phi -> Connection -> IO ()
-receiveEvents phi conn = do
-  forever $ waitForEvent conn >>= sendMessage phi . XEvent
+receiveEvents phi conn =
+  forever $ receiveEvents' conn >>= sendMessages phi
 
 updatePanels :: (Widget w s c X11) => PhiX w s c ()
 updatePanels = do
-- 
cgit v1.2.3