43 lines
1.3 KiB
Haskell
43 lines
1.3 KiB
Haskell
{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable, StandaloneDeriving #-}
|
|
|
|
module Phi.Phi ( Phi
|
|
, Message
|
|
, DefaultMessage(..)
|
|
, fromMessage
|
|
, initPhi
|
|
, dupPhi
|
|
, sendMessage
|
|
, receiveMessage
|
|
, messageAvailable
|
|
) where
|
|
|
|
import Control.Concurrent.STM
|
|
import Control.Monad
|
|
import Control.Monad.IO.Class
|
|
|
|
import Data.Typeable
|
|
|
|
data Phi = Phi (TChan Message)
|
|
|
|
data Message = forall a. (Typeable a, Show a) => Message a
|
|
deriving instance Show Message
|
|
|
|
data DefaultMessage = Repaint deriving (Typeable, Show)
|
|
|
|
fromMessage :: (Typeable a, Show a) => Message -> Maybe a
|
|
fromMessage (Message m) = cast m
|
|
|
|
initPhi :: MonadIO m => m Phi
|
|
initPhi = liftM Phi $ liftIO $ atomically newTChan
|
|
|
|
dupPhi :: MonadIO m => Phi -> m Phi
|
|
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
|
|
|
|
receiveMessage :: MonadIO m => Phi -> m Message
|
|
receiveMessage (Phi chan) = liftIO $ atomically $ readTChan chan
|
|
|
|
messageAvailable :: MonadIO m => Phi -> m Bool
|
|
messageAvailable (Phi chan) = liftIO $ liftM not $ atomically $ isEmptyTChan chan
|