diff options
| author | Matthias Schiffer <mschiffer@universe-factory.net> | 2011-10-07 05:31:23 +0200 |
|---|---|---|
| committer | Matthias Schiffer <mschiffer@universe-factory.net> | 2011-10-07 05:31:23 +0200 |
| commit | 579552b29b396943c3a2c97456c37c8005729ce1 (patch) | |
| tree | 1d67b4da005ebce9c1378ce3f4aa5c920f95c284 | |
| parent | 5cb4744d4f8bae31c17802f1e57fe31bf747f469 (diff) | |
| download | phi-579552b29b396943c3a2c97456c37c8005729ce1.tar phi-579552b29b396943c3a2c97456c37c8005729ce1.zip | |
Send X message batched
| -rw-r--r-- | lib/Phi/Phi.hs | 4 | ||||
| -rw-r--r-- | lib/Phi/X11.hs | 23 |
2 files changed, 24 insertions, 3 deletions
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 |