{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# LANGUAGE CPP, DeriveDataTypeable #-}

#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Concurrent.STM.TChan
-- Copyright   :  (c) The University of Glasgow 2004
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable (requires STM)
--
-- TChan: Transactional channels
-- (GHC only)
--
-----------------------------------------------------------------------------

module Control.Concurrent.STM.TChan (
#ifdef __GLASGOW_HASKELL__
        -- * TChans
        TChan,

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

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

#ifdef __GLASGOW_HASKELL__
import GHC.Conc

import Data.Typeable (Typeable)

#define _UPK_(x) {-# UNPACK #-} !(x)

-- | 'TChan' is an abstract type representing an unbounded FIFO channel.
data TChan a = TChan _UPK_(TVar (TVarList a))
                     _UPK_(TVar (TVarList a))
  deriving (TChan a -> TChan a -> Bool
(TChan a -> TChan a -> Bool)
-> (TChan a -> TChan a -> Bool) -> Eq (TChan a)
forall a. TChan a -> TChan a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TChan a -> TChan a -> Bool
$c/= :: forall a. TChan a -> TChan a -> Bool
== :: TChan a -> TChan a -> Bool
$c== :: forall a. TChan a -> TChan a -> Bool
Eq, Typeable)

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

-- |Build and return a new instance of 'TChan'
newTChan :: STM (TChan a)
newTChan :: STM (TChan a)
newTChan = do
  TVar (TList a)
hole <- TList a -> STM (TVar (TList a))
forall a. a -> STM (TVar a)
newTVar TList a
forall a. TList a
TNil
  TVar (TVar (TList a))
read <- TVar (TList a) -> STM (TVar (TVar (TList a)))
forall a. a -> STM (TVar a)
newTVar TVar (TList a)
hole
  TVar (TVar (TList a))
write <- TVar (TList a) -> STM (TVar (TVar (TList a)))
forall a. a -> STM (TVar a)
newTVar TVar (TList a)
hole
  TChan a -> STM (TChan a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar (TVar (TList a)) -> TVar (TVar (TList a)) -> TChan a
forall a. TVar (TVarList a) -> TVar (TVarList a) -> TChan a
TChan TVar (TVar (TList a))
read TVar (TVar (TList a))
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 :: IO (TChan a)
newTChanIO = do
  TVar (TList a)
hole <- TList a -> IO (TVar (TList a))
forall a. a -> IO (TVar a)
newTVarIO TList a
forall a. TList a
TNil
  TVar (TVar (TList a))
read <- TVar (TList a) -> IO (TVar (TVar (TList a)))
forall a. a -> IO (TVar a)
newTVarIO TVar (TList a)
hole
  TVar (TVar (TList a))
write <- TVar (TList a) -> IO (TVar (TVar (TList a)))
forall a. a -> IO (TVar a)
newTVarIO TVar (TList a)
hole
  TChan a -> IO (TChan a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar (TVar (TList a)) -> TVar (TVar (TList a)) -> TChan a
forall a. TVar (TVarList a) -> TVar (TVarList a) -> TChan a
TChan TVar (TVar (TList a))
read TVar (TVar (TList a))
write)

-- | 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'.
--
-- Consider a server that broadcasts messages to clients:
--
-- >serve :: TChan Message -> Client -> IO loop
-- >serve broadcastChan client = do
-- >    myChan <- dupTChan broadcastChan
-- >    forever $ do
-- >        message <- readTChan myChan
-- >        send client message
--
-- The problem with using 'newTChan' to create the broadcast channel is that if
-- it is only written to and never read, items will pile up in memory.  By
-- using 'newBroadcastTChan' to create the broadcast channel, items can be
-- garbage collected after clients have seen them.
--
-- @since 2.4
newBroadcastTChan :: STM (TChan a)
newBroadcastTChan :: STM (TChan a)
newBroadcastTChan = do
    TVar (TList a)
write_hole <- TList a -> STM (TVar (TList a))
forall a. a -> STM (TVar a)
newTVar TList a
forall a. TList a
TNil
    TVar (TVar (TList a))
read <- TVar (TList a) -> STM (TVar (TVar (TList a)))
forall a. a -> STM (TVar a)
newTVar ([Char] -> TVar (TList a)
forall a. HasCallStack => [Char] -> a
error [Char]
"reading from a TChan created by newBroadcastTChan; use dupTChan first")
    TVar (TVar (TList a))
write <- TVar (TList a) -> STM (TVar (TVar (TList a)))
forall a. a -> STM (TVar a)
newTVar TVar (TList a)
write_hole
    TChan a -> STM (TChan a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar (TVar (TList a)) -> TVar (TVar (TList a)) -> TChan a
forall a. TVar (TVarList a) -> TVar (TVarList a) -> TChan a
TChan TVar (TVar (TList a))
read TVar (TVar (TList a))
write)

-- | @IO@ version of 'newBroadcastTChan'.
--
-- @since 2.4
newBroadcastTChanIO :: IO (TChan a)
newBroadcastTChanIO :: IO (TChan a)
newBroadcastTChanIO = do
    TVar (TList a)
write_hole <- TList a -> IO (TVar (TList a))
forall a. a -> IO (TVar a)
newTVarIO TList a
forall a. TList a
TNil
    TVar (TVar (TList a))
read <- TVar (TList a) -> IO (TVar (TVar (TList a)))
forall a. a -> IO (TVar a)
newTVarIO ([Char] -> TVar (TList a)
forall a. HasCallStack => [Char] -> a
error [Char]
"reading from a TChan created by newBroadcastTChanIO; use dupTChan first")
    TVar (TVar (TList a))
write <- TVar (TList a) -> IO (TVar (TVar (TList a)))
forall a. a -> IO (TVar a)
newTVarIO TVar (TList a)
write_hole
    TChan a -> IO (TChan a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar (TVar (TList a)) -> TVar (TVar (TList a)) -> TChan a
forall a. TVar (TVarList a) -> TVar (TVarList a) -> TChan a
TChan TVar (TVar (TList a))
read TVar (TVar (TList a))
write)

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

-- |Read the next value from the 'TChan'.
readTChan :: TChan a -> STM a
readTChan :: TChan a -> STM a
readTChan (TChan TVar (TVarList a)
read TVar (TVarList a)
_write) = do
  TVarList a
listhead <- TVar (TVarList a) -> STM (TVarList a)
forall a. TVar a -> STM a
readTVar TVar (TVarList a)
read
  TList a
head <- TVarList a -> STM (TList a)
forall a. TVar a -> STM a
readTVar TVarList a
listhead
  case TList a
head of
    TList a
TNil -> STM a
forall a. STM a
retry
    TCons a
a TVarList a
tail -> do
        TVar (TVarList a) -> TVarList a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (TVarList a)
read TVarList a
tail
        a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | A version of 'readTChan' which does not retry. Instead it
-- returns @Nothing@ if no value is available.
--
-- @since 2.3
tryReadTChan :: TChan a -> STM (Maybe a)
tryReadTChan :: TChan a -> STM (Maybe a)
tryReadTChan (TChan TVar (TVarList a)
read TVar (TVarList a)
_write) = do
  TVarList a
listhead <- TVar (TVarList a) -> STM (TVarList a)
forall a. TVar a -> STM a
readTVar TVar (TVarList a)
read
  TList a
head <- TVarList a -> STM (TList a)
forall a. TVar a -> STM a
readTVar TVarList a
listhead
  case TList a
head of
    TList a
TNil       -> Maybe a -> STM (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    TCons a
a TVarList a
tl -> do
      TVar (TVarList a) -> TVarList a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (TVarList a)
read TVarList a
tl
      Maybe a -> STM (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (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 2.3
peekTChan :: TChan a -> STM a
peekTChan :: TChan a -> STM a
peekTChan (TChan TVar (TVarList a)
read TVar (TVarList a)
_write) = do
  TVarList a
listhead <- TVar (TVarList a) -> STM (TVarList a)
forall a. TVar a -> STM a
readTVar TVar (TVarList a)
read
  TList a
head <- TVarList a -> STM (TList a)
forall a. TVar a -> STM a
readTVar TVarList a
listhead
  case TList a
head of
    TList a
TNil      -> STM a
forall a. STM a
retry
    TCons a
a TVarList a
_ -> a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | A version of 'peekTChan' which does not retry. Instead it
-- returns @Nothing@ if no value is available.
--
-- @since 2.3
tryPeekTChan :: TChan a -> STM (Maybe a)
tryPeekTChan :: TChan a -> STM (Maybe a)
tryPeekTChan (TChan TVar (TVarList a)
read TVar (TVarList a)
_write) = do
  TVarList a
listhead <- TVar (TVarList a) -> STM (TVarList a)
forall a. TVar a -> STM a
readTVar TVar (TVarList a)
read
  TList a
head <- TVarList a -> STM (TList a)
forall a. TVar a -> STM a
readTVar TVarList a
listhead
  case TList a
head of
    TList a
TNil      -> Maybe a -> STM (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    TCons a
a TVarList a
_ -> Maybe a -> STM (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (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.
dupTChan :: TChan a -> STM (TChan a)
dupTChan :: TChan a -> STM (TChan a)
dupTChan (TChan TVar (TVarList a)
_read TVar (TVarList a)
write) = do
  TVarList a
hole <- TVar (TVarList a) -> STM (TVarList a)
forall a. TVar a -> STM a
readTVar TVar (TVarList a)
write
  TVar (TVarList a)
new_read <- TVarList a -> STM (TVar (TVarList a))
forall a. a -> STM (TVar a)
newTVar TVarList a
hole
  TChan a -> STM (TChan a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar (TVarList a) -> TVar (TVarList a) -> TChan a
forall a. TVar (TVarList a) -> TVar (TVarList a) -> TChan a
TChan TVar (TVarList a)
new_read TVar (TVarList a)
write)

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

-- |Returns 'True' if the supplied 'TChan' is empty.
isEmptyTChan :: TChan a -> STM Bool
isEmptyTChan :: TChan a -> STM Bool
isEmptyTChan (TChan TVar (TVarList a)
read TVar (TVarList a)
_write) = do
  TVarList a
listhead <- TVar (TVarList a) -> STM (TVarList a)
forall a. TVar a -> STM a
readTVar TVar (TVarList a)
read
  TList a
head <- TVarList a -> STM (TList a)
forall a. TVar a -> STM a
readTVar TVarList a
listhead
  case TList a
head of
    TList a
TNil -> Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    TCons a
_ TVarList a
_ -> Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- |Clone a 'TChan': similar to dupTChan, but the cloned channel starts with the
-- same content available as the original channel.
--
-- @since 2.4
cloneTChan :: TChan a -> STM (TChan a)
cloneTChan :: TChan a -> STM (TChan a)
cloneTChan (TChan TVar (TVarList a)
read TVar (TVarList a)
write) = do
  TVarList a
readpos <- TVar (TVarList a) -> STM (TVarList a)
forall a. TVar a -> STM a
readTVar TVar (TVarList a)
read
  TVar (TVarList a)
new_read <- TVarList a -> STM (TVar (TVarList a))
forall a. a -> STM (TVar a)
newTVar TVarList a
readpos
  TChan a -> STM (TChan a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar (TVarList a) -> TVar (TVarList a) -> TChan a
forall a. TVar (TVarList a) -> TVar (TVarList a) -> TChan a
TChan TVar (TVarList a)
new_read TVar (TVarList a)
write)
#endif