-- |
-- 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 :: stm (TChan stm a)
newTChan = do
  TVar stm (TList stm a)
hole   <- TList stm a -> stm (TVar stm (TList stm a))
forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar TList stm a
forall (stm :: * -> *) a. TList stm a
TNil
  TVar stm (TVar stm (TList stm a))
readH  <- TVar stm (TList stm a) -> stm (TVar stm (TVar stm (TList stm a)))
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 <- TVar stm (TList stm a) -> stm (TVar stm (TVar stm (TList stm a)))
forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar TVar stm (TList stm a)
hole
  TChan stm a -> stm (TChan stm a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TVar stm (TVar stm (TList stm a))
-> TVar stm (TVar stm (TList stm a)) -> TChan stm a
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 :: stm (TChan stm a)
newBroadcastTChan = do
    TVar stm (TList stm a)
hole   <- TList stm a -> stm (TVar stm (TList stm a))
forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar TList stm a
forall (stm :: * -> *) a. TList stm a
TNil
    TVar stm (TVar stm (TList stm a))
readT  <- TVar stm (TList stm a) -> stm (TVar stm (TVar stm (TList stm a)))
forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar ([Char] -> TVar stm (TList stm a)
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 <- TVar stm (TList stm a) -> stm (TVar stm (TVar stm (TList stm a)))
forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar TVar stm (TList stm a)
hole
    TChan stm a -> stm (TChan stm a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TVar stm (TVar stm (TList stm a))
-> TVar stm (TVar stm (TList stm a)) -> TChan stm a
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 :: 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  <- TVar stm (TVarList stm a) -> stm (TVarList stm a)
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm (TVarList stm a)
writeT
  TVarList stm a
listend' <- TList stm a -> stm (TVarList stm a)
forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar TList stm a
forall (stm :: * -> *) a. TList stm a
TNil
  TVarList stm a -> TList stm a -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVarList stm a
listend (a -> TVarList stm a -> TList stm a
forall (stm :: * -> *) a. a -> TVarList stm a -> TList stm a
TCons a
a TVarList stm a
listend')
  TVar stm (TVarList stm a) -> TVarList stm a -> stm ()
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 :: TChan stm a -> stm a
readTChan TChan stm a
tchan = TChan stm a -> stm (Maybe a)
forall (stm :: * -> *) a.
MonadSTM stm =>
TChan stm a -> stm (Maybe a)
tryReadTChan TChan stm a
tchan stm (Maybe a) -> (Maybe a -> stm a) -> stm a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= stm a -> (a -> stm a) -> Maybe a -> stm a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe stm a
forall (stm :: * -> *) a. MonadSTM stm => stm a
retry a -> stm a
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 :: TChan stm a -> stm (Maybe a)
tryReadTChan (TChan TVar stm (TVarList stm a)
readT TVar stm (TVarList stm a)
_) = do
  TVarList stm a
listhead <- TVar stm (TVarList stm a) -> stm (TVarList stm a)
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm (TVarList stm a)
readT
  TList stm a
hd <- TVarList stm a -> stm (TList stm a)
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       -> Maybe a -> stm (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    TCons a
a TVarList stm a
tl -> do
      TVar stm (TVarList stm a) -> TVarList stm a -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm (TVarList stm a)
readT TVarList stm a
tl
      Maybe a -> stm (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
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 :: TChan stm a -> stm a
peekTChan TChan stm a
tchan = TChan stm a -> stm (Maybe a)
forall (stm :: * -> *) a.
MonadSTM stm =>
TChan stm a -> stm (Maybe a)
tryPeekTChan TChan stm a
tchan stm (Maybe a) -> (Maybe a -> stm a) -> stm a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= stm a -> (a -> stm a) -> Maybe a -> stm a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe stm a
forall (stm :: * -> *) a. MonadSTM stm => stm a
retry a -> stm a
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 :: TChan stm a -> stm (Maybe a)
tryPeekTChan (TChan TVar stm (TVarList stm a)
readT TVar stm (TVarList stm a)
_) = do
  TVarList stm a
listhead <- TVar stm (TVarList stm a) -> stm (TVarList stm a)
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm (TVarList stm a)
readT
  TList stm a
hd <- TVarList stm a -> stm (TList stm a)
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVarList stm a
listhead
  Maybe a -> stm (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> stm (Maybe a)) -> Maybe a -> stm (Maybe a)
forall a b. (a -> b) -> a -> b
$ case TList stm a
hd of
    TList stm a
TNil      -> Maybe a
forall a. Maybe a
Nothing
    TCons a
a TVarList stm a
_ -> a -> Maybe 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 :: 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   <- TVar stm (TVarList stm a) -> stm (TVarList stm a)
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm (TVarList stm a)
writeT
  TVar stm (TVarList stm a)
readT' <- TVarList stm a -> stm (TVar stm (TVarList stm a))
forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar TVarList stm a
hole
  TChan stm a -> stm (TChan stm a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TVar stm (TVarList stm a)
-> TVar stm (TVarList stm a) -> TChan stm a
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 :: 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 <- TVar stm (TVarList stm a) -> stm (TVarList stm a)
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm (TVarList stm a)
readT
   TVarList stm a
head' <- TList stm a -> stm (TVarList stm a)
forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar (a -> TVarList stm a -> TList stm a
forall (stm :: * -> *) a. a -> TVarList stm a -> TList stm a
TCons a
a TVarList stm a
listhead)
   TVar stm (TVarList stm a) -> TVarList stm a -> stm ()
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 :: TChan stm a -> stm Bool
isEmptyTChan (TChan TVar stm (TVarList stm a)
readT TVar stm (TVarList stm a)
_) = do
  TVarList stm a
listhead <- TVar stm (TVarList stm a) -> stm (TVarList stm a)
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm (TVarList stm a)
readT
  TList stm a
hd <- TVarList stm a -> stm (TList stm a)
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVarList stm a
listhead
  Bool -> stm Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> stm Bool) -> Bool -> stm Bool
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 :: 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 <- TVar stm (TVarList stm a) -> stm (TVarList stm a)
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm (TVarList stm a)
readT
  TVar stm (TVarList stm a)
readT' <- TVarList stm a -> stm (TVar stm (TVarList stm a))
forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar TVarList stm a
readpos
  TChan stm a -> stm (TChan stm a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TVar stm (TVarList stm a)
-> TVar stm (TVarList stm a) -> TChan stm a
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)