TChan.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Concurrent.AdvSTM.TChan
-- Copyright   :  (c) Peter Robinson 2009,  The University of Glasgow 2004
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Peter Robinson <robinson@ecs.tuwien.ac.at>
-- Stability   :  experimental
-- Portability :  non-portable (requires STM)
--
-- Corresponds to "Control.Concurrent.STM.TChan"
--
-----------------------------------------------------------------------------
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)

-- | 'TChan' is an abstract type representing an unbounded FIFO channel.
data TChan a = TChan (TVar (TVarList a)) (TVar (TVarList a))

type TVarList a = TVar (TList a)
data TList a = TNil | TCons a (TVarList a)

-- |Build and returns a new instance of 'TChan'
newTChan :: MonadAdvSTM m => m (TChan a)
newTChan = do
  hole <- newTVar TNil
  read <- newTVar hole
  write <- newTVar hole
  return (TChan read write)

-- |@IO@ version of 'newTChan'.  This is useful for creating top-level
-- 'TChan's using 'System.IO.Unsafe.unsafePerformIO', because using
-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't
-- possible.
newTChanIO :: IO (TChan a)
newTChanIO = do
  hole <- newTVarIO TNil
  read <- newTVarIO hole
  write <- newTVarIO hole
  return (TChan read write)

-- |Write a value to a 'TChan'.
writeTChan :: MonadAdvSTM m => TChan a -> a -> m ()
writeTChan (TChan _read write) a = do
  listend <- readTVar write -- listend == TVar pointing to TNil
  new_listend <- newTVar TNil
  writeTVar listend (TCons a new_listend)
  writeTVar write new_listend

-- |Read the next value from the 'TChan'.
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

-- |Duplicate a 'TChan': the duplicate channel begins empty, but data written to
-- either channel from then on will be available from both.  Hence this creates
-- a kind of broadcast channel, where data written by anyone is seen by
-- everyone else.
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)

-- |Put a data item back onto a channel, where it will be the next item read.
unGetTChan :: MonadAdvSTM m => TChan a -> a -> m ()
unGetTChan (TChan read _write) a = do
   listhead <- readTVar read
   newhead <- newTVar (TCons a listhead)
   writeTVar read newhead

-- |Returns 'True' if the supplied 'TChan' is empty.
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