dejafu/concurrency/Control/Concurrent/Classy/STM/TChan.hs

-- |
-- Module      : Control.Concurrent.Classy.STM.TChan
-- Copyright   : (c) 2016 Michael Walker
-- License     : MIT
-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>
-- Stability   : stable
-- Portability : portable
--
-- Transactional channels
--
-- __Deviations:__ @TChan@ as defined here does not have an @Eq@
-- instance, this is because the @MonadSTM@ @TVar@ type does not have
-- an @Eq@ constraint. Furthermore, the @newTChanIO@ and
-- @newBroadcastTChanIO@ functions are not provided.
module Control.Concurrent.Classy.STM.TChan
  ( -- * TChans
    TChan

  -- * Construction
  , newTChan
  , newBroadcastTChan
  , dupTChan
  , cloneTChan

  -- * Reading and writing
  , readTChan
  , tryReadTChan
  , peekTChan
  , tryPeekTChan
  , writeTChan
  , unGetTChan
  , isEmptyTChan
  ) where

import           Control.Monad.STM.Class

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

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

-- |Build and return a new instance of 'TChan'
--
-- @since 1.0.0.0
newTChan :: MonadSTM stm => stm (TChan stm a)
newTChan = do
  hole   <- newTVar TNil
  readH  <- newTVar hole
  writeH <- newTVar hole
  pure (TChan readH writeH)

-- | Create a write-only 'TChan'.  More precisely, 'readTChan' will 'retry'
-- even after items have been written to the channel.  The only way to
-- read a broadcast channel is to duplicate it with 'dupTChan'.
--
-- @since 1.0.0.0
newBroadcastTChan :: MonadSTM stm => stm (TChan stm a)
newBroadcastTChan = do
    hole   <- newTVar TNil
    readT  <- newTVar (error "reading from a TChan created by newBroadcastTChan; use dupTChan first")
    writeT <- newTVar hole
    pure (TChan readT writeT)

-- | Write a value to a 'TChan'.
--
-- @since 1.0.0.0
writeTChan :: MonadSTM stm => TChan stm a -> a -> stm ()
writeTChan (TChan _ writeT) a = do
  listend  <- readTVar writeT
  listend' <- newTVar TNil
  writeTVar listend (TCons a listend')
  writeTVar writeT listend'

-- | Read the next value from the 'TChan'.
--
-- @since 1.0.0.0
readTChan :: MonadSTM stm => TChan stm a -> stm a
readTChan tchan = tryReadTChan tchan >>= maybe retry pure

-- | A version of 'readTChan' which does not retry. Instead it
-- returns @Nothing@ if no value is available.
--
-- @since 1.0.0.0
tryReadTChan :: MonadSTM stm => TChan stm a -> stm (Maybe a)
tryReadTChan (TChan readT _) = do
  listhead <- readTVar readT
  hd <- readTVar listhead
  case hd of
    TNil       -> pure Nothing
    TCons a tl -> do
      writeTVar readT tl
      pure (Just a)

-- | Get the next value from the 'TChan' without removing it,
-- retrying if the channel is empty.
--
-- @since 1.0.0.0
peekTChan :: MonadSTM stm => TChan stm a -> stm a
peekTChan tchan = tryPeekTChan tchan >>= maybe retry pure

-- | A version of 'peekTChan' which does not retry. Instead it
-- returns @Nothing@ if no value is available.
--
-- @since 1.0.0.0
tryPeekTChan :: MonadSTM stm => TChan stm a -> stm (Maybe a)
tryPeekTChan (TChan readT _) = do
  listhead <- readTVar readT
  hd <- readTVar listhead
  pure $ case hd of
    TNil      -> Nothing
    TCons a _ -> Just 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.
--
-- @since 1.0.0.0
dupTChan :: MonadSTM stm => TChan stm a -> stm (TChan stm a)
dupTChan (TChan _ writeT) = do
  hole   <- readTVar writeT
  readT' <- newTVar hole
  pure (TChan readT' writeT)

-- | Put a data item back onto a channel, where it will be the next
-- item read.
--
-- @since 1.0.0.0
unGetTChan :: MonadSTM stm => TChan stm a -> a -> stm ()
unGetTChan (TChan readT _) a = do
   listhead <- readTVar readT
   head' <- newTVar (TCons a listhead)
   writeTVar readT head'

-- | Returns 'True' if the supplied 'TChan' is empty.
--
-- @since 1.0.0.0
isEmptyTChan :: MonadSTM stm => TChan stm a -> stm Bool
isEmptyTChan (TChan readT _) = do
  listhead <- readTVar readT
  hd <- readTVar listhead
  pure $ case hd of
    TNil -> True
    TCons _ _ -> False

-- | Clone a 'TChan': similar to 'dupTChan', but the cloned channel starts with the
-- same content available as the original channel.
--
-- @since 1.0.0.0
cloneTChan :: MonadSTM stm => TChan stm a -> stm (TChan stm a)
cloneTChan (TChan readT writeT) = do
  readpos <- readTVar readT
  readT' <- newTVar readpos
  pure (TChan readT' writeT)