From 8854f0aec4b882324649d3a5ce1c99e8af9862d7 Mon Sep 17 00:00:00 2001
From: Matthias Schiffer <mschiffer@universe-factory.net>
Date: Sat, 16 Jul 2011 13:21:24 +0200
Subject: Don't redraw when there are still messages pending

---
 lib/Phi/Phi.hs | 16 ++++++++++------
 1 file changed, 10 insertions(+), 6 deletions(-)

(limited to 'lib/Phi/Phi.hs')

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
-- 
cgit v1.2.3