#if __GLASGOW_HASKELL__ >= 701
#endif
module Control.Concurrent.STM.TChan (
#ifdef __GLASGOW_HASKELL__
TChan,
newTChan,
newTChanIO,
newBroadcastTChan,
newBroadcastTChanIO,
dupTChan,
cloneTChan,
readTChan,
tryReadTChan,
peekTChan,
tryPeekTChan,
writeTChan,
unGetTChan,
isEmptyTChan
#endif
) where
#ifdef __GLASGOW_HASKELL__
import GHC.Conc
import Data.Typeable (Typeable)
#define _UPK_(x) {-# UNPACK #-} !(x)
data TChan a = TChan _UPK_(TVar (TVarList a))
_UPK_(TVar (TVarList a))
deriving (Eq, Typeable)
type TVarList a = TVar (TList a)
data TList a = TNil | TCons a _UPK_(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)
newBroadcastTChan :: STM (TChan a)
newBroadcastTChan = do
write_hole <- newTVar TNil
read <- newTVar (error "reading from a TChan created by newBroadcastTChan; use dupTChan first")
write <- newTVar write_hole
return (TChan read write)
newBroadcastTChanIO :: IO (TChan a)
newBroadcastTChanIO = do
write_hole <- newTVarIO TNil
read <- newTVarIO (error "reading from a TChan created by newBroadcastTChanIO; use dupTChan first")
write <- newTVarIO write_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
tryReadTChan :: TChan a -> STM (Maybe a)
tryReadTChan (TChan read _write) = do
listhead <- readTVar read
head <- readTVar listhead
case head of
TNil -> return Nothing
TCons a tl -> do
writeTVar read tl
return (Just a)
peekTChan :: TChan a -> STM a
peekTChan (TChan read _write) = do
listhead <- readTVar read
head <- readTVar listhead
case head of
TNil -> retry
TCons a _ -> return a
tryPeekTChan :: TChan a -> STM (Maybe a)
tryPeekTChan (TChan read _write) = do
listhead <- readTVar read
head <- readTVar listhead
case head of
TNil -> return Nothing
TCons a _ -> return (Just 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
cloneTChan :: TChan a -> STM (TChan a)
cloneTChan (TChan read write) = do
readpos <- readTVar read
new_read <- newTVar readpos
return (TChan new_read write)
#endif