module Control.Concurrent.STM.TChan (
#ifdef __GLASGOW_HASKELL__
TChan,
newTChan,
newTChanIO,
readTChan,
writeTChan,
dupTChan,
unGetTChan,
isEmptyTChan
#endif
) where
#ifdef __GLASGOW_HASKELL__
import GHC.Conc
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 :: STM (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 :: TChan a -> a -> STM ()
writeTChan (TChan _read write) a = do
listend <- readTVar write
new_listend <- newTVar TNil
writeTVar listend (TCons a new_listend)
writeTVar write new_listend
readTChan :: TChan a -> STM 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 :: TChan a -> STM (TChan a)
dupTChan (TChan read write) = do
hole <- readTVar write
new_read <- newTVar hole
return (TChan new_read write)
unGetTChan :: TChan a -> a -> STM ()
unGetTChan (TChan read _write) a = do
listhead <- readTVar read
newhead <- newTVar (TCons a listhead)
writeTVar read newhead
isEmptyTChan :: TChan a -> STM Bool
isEmptyTChan (TChan read write) = do
listhead <- readTVar read
head <- readTVar listhead
case head of
TNil -> return True
TCons _ _ -> return False
#endif