summaryrefslogtreecommitdiffstats
path: root/lib/Phi
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Phi')
-rw-r--r--lib/Phi/Phi.hs4
-rw-r--r--lib/Phi/X11.hs23
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