-- |
-- 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 :: forall (stm :: * -> *) a. MonadSTM stm => stm (TChan stm a)
newTChan = do
  TVar stm (TList stm a)
hole   <- forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar forall (stm :: * -> *) a. TList stm a
TNil
  TVar stm (TVar stm (TList stm a))
readH  <- forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar TVar stm (TList stm a)
hole
  TVar stm (TVar stm (TList stm a))
writeH <- forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar TVar stm (TList stm a)
hole
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (stm :: * -> *) a.
TVar stm (TVarList stm a)
-> TVar stm (TVarList stm a) -> TChan stm a
TChan TVar stm (TVar stm (TList stm a))
readH TVar stm (TVar stm (TList stm a))
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 :: forall (stm :: * -> *) a. MonadSTM stm => stm (TChan stm a)
newBroadcastTChan = do
    TVar stm (TList stm a)
hole   <- forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar forall (stm :: * -> *) a. TList stm a
TNil
    TVar stm (TVar stm (TList stm a))
readT  <- forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar (forall a. HasCallStack => [Char] -> a
error [Char]
"reading from a TChan created by newBroadcastTChan; use dupTChan first")
    TVar stm (TVar stm (TList stm a))
writeT <- forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar TVar stm (TList stm a)
hole
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (stm :: * -> *) a.
TVar stm (TVarList stm a)
-> TVar stm (TVarList stm a) -> TChan stm a
TChan TVar stm (TVar stm (TList stm a))
readT TVar stm (TVar stm (TList stm a))
writeT)

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

-- | Read the next value from the 'TChan'.
--
-- @since 1.0.0.0
readTChan :: MonadSTM stm => TChan stm a -> stm a
readTChan :: forall (stm :: * -> *) a. MonadSTM stm => TChan stm a -> stm a
readTChan TChan stm a
tchan = forall (stm :: * -> *) a.
MonadSTM stm =>
TChan stm a -> stm (Maybe a)
tryReadTChan TChan stm a
tchan forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (stm :: * -> *) a. MonadSTM stm => stm a
retry forall (f :: * -> *) a. Applicative f => a -> f a
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 :: forall (stm :: * -> *) a.
MonadSTM stm =>
TChan stm a -> stm (Maybe a)
tryReadTChan (TChan TVar stm (TVarList stm a)
readT TVar stm (TVarList stm a)
_) = do
  TVarList stm a
listhead <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm (TVarList stm a)
readT
  TList stm a
hd <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVarList stm a
listhead
  case TList stm a
hd of
    TList stm a
TNil       -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    TCons a
a TVarList stm a
tl -> do
      forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm (TVarList stm a)
readT TVarList stm a
tl
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just a
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 :: forall (stm :: * -> *) a. MonadSTM stm => TChan stm a -> stm a
peekTChan TChan stm a
tchan = forall (stm :: * -> *) a.
MonadSTM stm =>
TChan stm a -> stm (Maybe a)
tryPeekTChan TChan stm a
tchan forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (stm :: * -> *) a. MonadSTM stm => stm a
retry forall (f :: * -> *) a. Applicative f => a -> f a
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 :: forall (stm :: * -> *) a.
MonadSTM stm =>
TChan stm a -> stm (Maybe a)
tryPeekTChan (TChan TVar stm (TVarList stm a)
readT TVar stm (TVarList stm a)
_) = do
  TVarList stm a
listhead <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm (TVarList stm a)
readT
  TList stm a
hd <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVarList stm a
listhead
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case TList stm a
hd of
    TList stm a
TNil      -> forall a. Maybe a
Nothing
    TCons a
a TVarList stm a
_ -> forall a. a -> Maybe a
Just a
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 :: forall (stm :: * -> *) a.
MonadSTM stm =>
TChan stm a -> stm (TChan stm a)
dupTChan (TChan TVar stm (TVarList stm a)
_ TVar stm (TVarList stm a)
writeT) = do
  TVarList stm a
hole   <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm (TVarList stm a)
writeT
  TVar stm (TVarList stm a)
readT' <- forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar TVarList stm a
hole
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (stm :: * -> *) a.
TVar stm (TVarList stm a)
-> TVar stm (TVarList stm a) -> TChan stm a
TChan TVar stm (TVarList stm a)
readT' TVar stm (TVarList stm a)
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 :: forall (stm :: * -> *) a.
MonadSTM stm =>
TChan stm a -> a -> stm ()
unGetTChan (TChan TVar stm (TVarList stm a)
readT TVar stm (TVarList stm a)
_) a
a = do
   TVarList stm a
listhead <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm (TVarList stm a)
readT
   TVarList stm a
head' <- forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar (forall (stm :: * -> *) a. a -> TVarList stm a -> TList stm a
TCons a
a TVarList stm a
listhead)
   forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm (TVarList stm a)
readT TVarList stm a
head'

-- | Returns 'True' if the supplied 'TChan' is empty.
--
-- @since 1.0.0.0
isEmptyTChan :: MonadSTM stm => TChan stm a -> stm Bool
isEmptyTChan :: forall (stm :: * -> *) a. MonadSTM stm => TChan stm a -> stm Bool
isEmptyTChan (TChan TVar stm (TVarList stm a)
readT TVar stm (TVarList stm a)
_) = do
  TVarList stm a
listhead <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm (TVarList stm a)
readT
  TList stm a
hd <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVarList stm a
listhead
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case TList stm a
hd of
    TList stm a
TNil -> Bool
True
    TCons a
_ TVarList stm a
_ -> Bool
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 :: forall (stm :: * -> *) a.
MonadSTM stm =>
TChan stm a -> stm (TChan stm a)
cloneTChan (TChan TVar stm (TVarList stm a)
readT TVar stm (TVarList stm a)
writeT) = do
  TVarList stm a
readpos <- forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm (TVarList stm a)
readT
  TVar stm (TVarList stm a)
readT' <- forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar TVarList stm a
readpos
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (stm :: * -> *) a.
TVar stm (TVarList stm a)
-> TVar stm (TVarList stm a) -> TChan stm a
TChan TVar stm (TVarList stm a)
readT' TVar stm (TVarList stm a)
writeT)