module Control.Concurrent.AdvSTM.TChan( TChan
, newTChan
, newTChanIO
, readTChan
, writeTChan
, dupTChan
, unGetTChan
, isEmptyTChan
)
where
import Control.Monad.AdvSTM(MonadAdvSTM,retry)
import Control.Concurrent.AdvSTM.TVar(TVar,readTVar,writeTVar,newTVar,newTVarIO)
data TChan a = TChan (TVar (TVarList a)) (TVar (TVarList a))
type TVarList a = TVar (TList a)
data TList a = TNil | TCons a (TVarList a)
newTChan :: MonadAdvSTM m => m (TChan a)
newTChan = do
hole <- newTVar TNil
read <- newTVar hole
write <- newTVar hole
return (TChan read write)
newTChanIO :: IO (TChan a)
newTChanIO = do
hole <- newTVarIO TNil
read <- newTVarIO hole
write <- newTVarIO hole
return (TChan read write)
writeTChan :: MonadAdvSTM m => TChan a -> a -> m ()
writeTChan (TChan _read write) a = do
listend <- readTVar write
new_listend <- newTVar TNil
writeTVar listend (TCons a new_listend)
writeTVar write new_listend
readTChan :: MonadAdvSTM m => TChan a -> m a
readTChan (TChan read _write) = do
listhead <- readTVar read
head <- readTVar listhead
case head of
TNil -> retry
TCons a tail -> do
writeTVar read tail
return a
dupTChan :: MonadAdvSTM m => TChan a -> m (TChan a)
dupTChan (TChan read write) = do
hole <- readTVar write
new_read <- newTVar hole
return (TChan new_read write)
unGetTChan :: MonadAdvSTM m => TChan a -> a -> m ()
unGetTChan (TChan read _write) a = do
listhead <- readTVar read
newhead <- newTVar (TCons a listhead)
writeTVar read newhead
isEmptyTChan :: MonadAdvSTM m => TChan a -> m Bool
isEmptyTChan (TChan read write) = do
listhead <- readTVar read
head <- readTVar listhead
case head of
TNil -> return True
TCons _ _ -> return False