neocturne/phi
Archived
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Send X message batched

Browse source
This commit is contained in:
Matthias Schiffer 2011-10-07 05:31:23 +02:00
parent 5cb4744d4f
commit 579552b29b
2 changed files with 24 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
lib/Phi/Phi.hs
View file

@ -7,6 +7,7 @@ module Phi.Phi ( Phi
, initPhi , initPhi
, dupPhi , dupPhi
, sendMessage , sendMessage
, sendMessages
, receiveMessage , receiveMessage
, messageAvailable , messageAvailable
) where ) 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 :: (MonadIO m, Typeable a, Show a) => Phi -> a -> m ()
sendMessage (Phi chan) = liftIO . atomically . writeTChan chan . Message 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 :: MonadIO m => Phi -> m Message
receiveMessage (Phi chan) = liftIO $ atomically $ readTChan chan receiveMessage (Phi chan) = liftIO $ atomically $ readTChan chan

23
lib/Phi/X11.hs
View file

@ -179,7 +179,7 @@ runPhi xconfig config widget = do
forever $ do forever $ do
available <- messageAvailable phi available <- messageAvailable phi
repaint <- gets phiRepaint repaint <- gets phiRepaint
when (not available && repaint) $ liftIO $ threadDelay 20000 when (not available && repaint) $ liftIO $ threadDelay 30000
available <- messageAvailable phi available <- messageAvailable phi
when (not available && repaint) $ do when (not available && repaint) $ do
@ -296,9 +296,26 @@ handleConfigureNotifyEvent MkConfigureNotifyEvent { window_ConfigureNotifyEvent
sendMessage phi $ UpdateScreens $ map (panelScreenArea &&& panelWindow) panels' sendMessage phi $ UpdateScreens $ map (panelScreenArea &&& panelWindow) panels'
sendMessage phi Repaint 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 -> Connection -> IO ()
receiveEvents phi conn = do receiveEvents phi conn =
forever $ waitForEvent conn >>= sendMessage phi . XEvent forever $ receiveEvents' conn >>= sendMessages phi
updatePanels :: (Widget w s c X11) => PhiX w s c () updatePanels :: (Widget w s c X11) => PhiX w s c ()
updatePanels = do updatePanels = do