diff options
author | Matthias Schiffer <mschiffer@universe-factory.net> | 2011-07-16 13:21:24 +0200 |
---|---|---|
committer | Matthias Schiffer <mschiffer@universe-factory.net> | 2011-07-16 13:21:24 +0200 |
commit | 8854f0aec4b882324649d3a5ce1c99e8af9862d7 (patch) | |
tree | a7668d0c317630253b54595927639306702b9450 /lib/Phi/Phi.hs | |
parent | b2b35e632a354fc0ffb944553adffbb58ad1e006 (diff) | |
download | phi-8854f0aec4b882324649d3a5ce1c99e8af9862d7.tar phi-8854f0aec4b882324649d3a5ce1c99e8af9862d7.zip |
Don't redraw when there are still messages pending
Diffstat (limited to 'lib/Phi/Phi.hs')
-rw-r--r-- | lib/Phi/Phi.hs | 16 |
1 files changed, 10 insertions, 6 deletions
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 |