{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
{-# LANGUAGE CPP, DeriveDataTypeable #-}
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
#endif
module Control.Concurrent.STM.TBChan
(
TBChan()
, newTBChan
, newTBChanIO
, readTBChan
, tryReadTBChan
, peekTBChan
, tryPeekTBChan
, writeTBChan
, tryWriteTBChan
, unGetTBChan
, isEmptyTBChan
, isFullTBChan
, estimateFreeSlotsTBChan
, freeSlotsTBChan
) where
import Prelude hiding (reads)
import Data.Typeable (Typeable)
import Control.Monad.STM (STM, retry)
import Control.Concurrent.STM.TVar
import Control.Concurrent.STM.TChan
data TBChan a = TBChan
{-# UNPACK #-} !(TVar Int)
{-# UNPACK #-} !(TVar Int)
{-# UNPACK #-} !(TChan a)
deriving (Typeable)
newTBChan :: Int -> STM (TBChan a)
newTBChan :: forall a. Int -> STM (TBChan a)
newTBChan Int
n = do
slots <- Int -> STM (TVar Int)
forall a. a -> STM (TVar a)
newTVar Int
n
reads <- newTVar 0
chan <- newTChan
return (TBChan slots reads chan)
newTBChanIO :: Int -> IO (TBChan a)
newTBChanIO :: forall a. Int -> IO (TBChan a)
newTBChanIO Int
n = do
slots <- Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
n
reads <- newTVarIO 0
chan <- newTChanIO
return (TBChan slots reads chan)
readTBChan :: TBChan a -> STM a
readTBChan :: forall a. TBChan a -> STM a
readTBChan (TBChan TVar Int
_slots TVar Int
reads TChan a
chan) = do
x <- TChan a -> STM a
forall a. TChan a -> STM a
readTChan TChan a
chan
modifyTVar' reads (1 +)
return x
tryReadTBChan :: TBChan a -> STM (Maybe a)
tryReadTBChan :: forall a. TBChan a -> STM (Maybe a)
tryReadTBChan (TBChan TVar Int
_slots TVar Int
reads TChan a
chan) = do
mx <- TChan a -> STM (Maybe a)
forall a. TChan a -> STM (Maybe a)
tryReadTChan TChan a
chan
case mx of
Maybe a
Nothing -> Maybe a -> STM (Maybe a)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
Just a
_x -> do
TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
reads (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+)
Maybe a -> STM (Maybe a)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
mx
peekTBChan :: TBChan a -> STM a
peekTBChan :: forall a. TBChan a -> STM a
peekTBChan (TBChan TVar Int
_slots TVar Int
_reads TChan a
chan) =
TChan a -> STM a
forall a. TChan a -> STM a
peekTChan TChan a
chan
tryPeekTBChan :: TBChan a -> STM (Maybe a)
tryPeekTBChan :: forall a. TBChan a -> STM (Maybe a)
tryPeekTBChan (TBChan TVar Int
_slots TVar Int
_reads TChan a
chan) =
TChan a -> STM (Maybe a)
forall a. TChan a -> STM (Maybe a)
tryPeekTChan TChan a
chan
writeTBChan :: TBChan a -> a -> STM ()
writeTBChan :: forall a. TBChan a -> a -> STM ()
writeTBChan self :: TBChan a
self@(TBChan TVar Int
slots TVar Int
_reads TChan a
chan) a
x = do
n <- TBChan a -> STM Int
forall a. TBChan a -> STM Int
estimateFreeSlotsTBChan TBChan a
self
if n <= 0
then retry
else do
writeTVar slots $! n - 1
writeTChan chan x
tryWriteTBChan :: TBChan a -> a -> STM Bool
tryWriteTBChan :: forall a. TBChan a -> a -> STM Bool
tryWriteTBChan self :: TBChan a
self@(TBChan TVar Int
slots TVar Int
_reads TChan a
chan) a
x = do
n <- TBChan a -> STM Int
forall a. TBChan a -> STM Int
estimateFreeSlotsTBChan TBChan a
self
if n <= 0
then return False
else do
writeTVar slots $! n - 1
writeTChan chan x
return True
unGetTBChan :: TBChan a -> a -> STM ()
unGetTBChan :: forall a. TBChan a -> a -> STM ()
unGetTBChan (TBChan TVar Int
slots TVar Int
_reads TChan a
chan) a
x = do
TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
slots (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1)
TChan a -> a -> STM ()
forall a. TChan a -> a -> STM ()
unGetTChan TChan a
chan a
x
isEmptyTBChan :: TBChan a -> STM Bool
isEmptyTBChan :: forall a. TBChan a -> STM Bool
isEmptyTBChan (TBChan TVar Int
_slots TVar Int
_reads TChan a
chan) =
TChan a -> STM Bool
forall a. TChan a -> STM Bool
isEmptyTChan TChan a
chan
isFullTBChan :: TBChan a -> STM Bool
isFullTBChan :: forall a. TBChan a -> STM Bool
isFullTBChan (TBChan TVar Int
slots TVar Int
reads TChan a
_chan) = do
n <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
slots
if n <= 0
then do
m <- readTVar reads
let n' = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m
writeTVar slots $! n'
writeTVar reads 0
return $! n' <= 0
else return False
estimateFreeSlotsTBChan :: TBChan a -> STM Int
estimateFreeSlotsTBChan :: forall a. TBChan a -> STM Int
estimateFreeSlotsTBChan (TBChan TVar Int
slots TVar Int
reads TChan a
_chan) = do
n <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
slots
if n > 0
then return n
else do
m <- readTVar reads
let n' = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m
writeTVar slots $! n'
writeTVar reads 0
return n'
freeSlotsTBChan :: TBChan a -> STM Int
freeSlotsTBChan :: forall a. TBChan a -> STM Int
freeSlotsTBChan (TBChan TVar Int
slots TVar Int
reads TChan a
_chan) = do
n <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
slots
m <- readTVar reads
let n' = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m
writeTVar slots $! n'
writeTVar reads 0
return n'