{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
{-# LANGUAGE CPP, DeriveDataTypeable #-}
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
#endif
module Control.Concurrent.STM.TBMChan
(
TBMChan()
, newTBMChan
, newTBMChanIO
, readTBMChan
, tryReadTBMChan
, peekTBMChan
, tryPeekTBMChan
, writeTBMChan
, tryWriteTBMChan
, unGetTBMChan
, closeTBMChan
, isClosedTBMChan
, isEmptyTBMChan
, isFullTBMChan
, estimateFreeSlotsTBMChan
, freeSlotsTBMChan
) where
import Prelude hiding (reads)
import Data.Typeable (Typeable)
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
import Control.Monad.STM (STM, retry)
import Control.Concurrent.STM.TVar
import Control.Concurrent.STM.TChan
data TBMChan a = TBMChan
{-# UNPACK #-} !(TVar Bool)
{-# UNPACK #-} !(TVar Int)
{-# UNPACK #-} !(TVar Int)
{-# UNPACK #-} !(TChan a)
deriving (Typeable)
newTBMChan :: Int -> STM (TBMChan a)
newTBMChan :: forall a. Int -> STM (TBMChan a)
newTBMChan Int
n = do
TVar Bool
closed <- forall a. a -> STM (TVar a)
newTVar Bool
False
TVar Int
slots <- forall a. a -> STM (TVar a)
newTVar Int
n
TVar Int
reads <- forall a. a -> STM (TVar a)
newTVar Int
0
TChan a
chan <- forall a. STM (TChan a)
newTChan
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. TVar Bool -> TVar Int -> TVar Int -> TChan a -> TBMChan a
TBMChan TVar Bool
closed TVar Int
slots TVar Int
reads TChan a
chan)
newTBMChanIO :: Int -> IO (TBMChan a)
newTBMChanIO :: forall a. Int -> IO (TBMChan a)
newTBMChanIO Int
n = do
TVar Bool
closed <- forall a. a -> IO (TVar a)
newTVarIO Bool
False
TVar Int
slots <- forall a. a -> IO (TVar a)
newTVarIO Int
n
TVar Int
reads <- forall a. a -> IO (TVar a)
newTVarIO Int
0
TChan a
chan <- forall a. IO (TChan a)
newTChanIO
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. TVar Bool -> TVar Int -> TVar Int -> TChan a -> TBMChan a
TBMChan TVar Bool
closed TVar Int
slots TVar Int
reads TChan a
chan)
readTBMChan :: TBMChan a -> STM (Maybe a)
readTBMChan :: forall a. TBMChan a -> STM (Maybe a)
readTBMChan (TBMChan TVar Bool
closed TVar Int
_slots TVar Int
reads TChan a
chan) = do
Bool
b <- forall a. TVar a -> STM a
readTVar TVar Bool
closed
if Bool
b
then do
Maybe a
mx <- forall a. TChan a -> STM (Maybe a)
tryReadTChan TChan a
chan
case Maybe a
mx of
Maybe a
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
mx
Just a
_x -> do
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
reads (Int
1 forall a. Num a => a -> a -> a
+)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
mx
else do
a
x <- forall a. TChan a -> STM a
readTChan TChan a
chan
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
reads (Int
1 forall a. Num a => a -> a -> a
+)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
x)
tryReadTBMChan :: TBMChan a -> STM (Maybe (Maybe a))
tryReadTBMChan :: forall a. TBMChan a -> STM (Maybe (Maybe a))
tryReadTBMChan (TBMChan TVar Bool
closed TVar Int
_slots TVar Int
reads TChan a
chan) = do
Bool
b <- forall a. TVar a -> STM a
readTVar TVar Bool
closed
if Bool
b
then do
Maybe a
mx <- forall a. TChan a -> STM (Maybe a)
tryReadTChan TChan a
chan
case Maybe a
mx of
Maybe a
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just a
_x -> do
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
reads (Int
1 forall a. Num a => a -> a -> a
+)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Maybe a
mx)
else do
Maybe a
mx <- forall a. TChan a -> STM (Maybe a)
tryReadTChan TChan a
chan
case Maybe a
mx of
Maybe a
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Maybe a
mx)
Just a
_x -> do
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
reads (Int
1 forall a. Num a => a -> a -> a
+)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Maybe a
mx)
peekTBMChan :: TBMChan a -> STM (Maybe a)
peekTBMChan :: forall a. TBMChan a -> STM (Maybe a)
peekTBMChan (TBMChan TVar Bool
closed TVar Int
_slots TVar Int
_reads TChan a
chan) = do
Bool
b <- forall a. TVar a -> STM a
readTVar TVar Bool
closed
if Bool
b
then do
Bool
b' <- forall a. TChan a -> STM Bool
isEmptyTChan TChan a
chan
if Bool
b'
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
else forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TChan a -> STM a
peekTChan TChan a
chan
else forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TChan a -> STM a
peekTChan TChan a
chan
tryPeekTBMChan :: TBMChan a -> STM (Maybe (Maybe a))
tryPeekTBMChan :: forall a. TBMChan a -> STM (Maybe (Maybe a))
tryPeekTBMChan (TBMChan TVar Bool
closed TVar Int
_slots TVar Int
_reads TChan a
chan) = do
Bool
b <- forall a. TVar a -> STM a
readTVar TVar Bool
closed
if Bool
b
then forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TChan a -> STM (Maybe a)
tryPeekTChan TChan a
chan
else forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TChan a -> STM (Maybe a)
tryPeekTChan TChan a
chan
writeTBMChan :: TBMChan a -> a -> STM ()
writeTBMChan :: forall a. TBMChan a -> a -> STM ()
writeTBMChan self :: TBMChan a
self@(TBMChan TVar Bool
closed TVar Int
slots TVar Int
_reads TChan a
chan) a
x = do
Bool
b <- forall a. TVar a -> STM a
readTVar TVar Bool
closed
if Bool
b
then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do
Int
n <- forall a. TBMChan a -> STM Int
estimateFreeSlotsTBMChan TBMChan a
self
if Int
n forall a. Ord a => a -> a -> Bool
<= Int
0
then forall a. STM a
retry
else do
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
slots forall a b. (a -> b) -> a -> b
$! Int
n forall a. Num a => a -> a -> a
- Int
1
forall a. TChan a -> a -> STM ()
writeTChan TChan a
chan a
x
tryWriteTBMChan :: TBMChan a -> a -> STM (Maybe Bool)
tryWriteTBMChan :: forall a. TBMChan a -> a -> STM (Maybe Bool)
tryWriteTBMChan self :: TBMChan a
self@(TBMChan TVar Bool
closed TVar Int
slots TVar Int
_reads TChan a
chan) a
x = do
Bool
b <- forall a. TVar a -> STM a
readTVar TVar Bool
closed
if Bool
b
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
else do
Int
n <- forall a. TBMChan a -> STM Int
estimateFreeSlotsTBMChan TBMChan a
self
if Int
n forall a. Ord a => a -> a -> Bool
<= Int
0
then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Bool
False)
else do
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
slots forall a b. (a -> b) -> a -> b
$! Int
n forall a. Num a => a -> a -> a
- Int
1
forall a. TChan a -> a -> STM ()
writeTChan TChan a
chan a
x
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Bool
True)
unGetTBMChan :: TBMChan a -> a -> STM ()
unGetTBMChan :: forall a. TBMChan a -> a -> STM ()
unGetTBMChan (TBMChan TVar Bool
closed TVar Int
slots TVar Int
_reads TChan a
chan) a
x = do
Bool
b <- forall a. TVar a -> STM a
readTVar TVar Bool
closed
if Bool
b
then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
slots (forall a. Num a => a -> a -> a
subtract Int
1)
forall a. TChan a -> a -> STM ()
unGetTChan TChan a
chan a
x
closeTBMChan :: TBMChan a -> STM ()
closeTBMChan :: forall a. TBMChan a -> STM ()
closeTBMChan (TBMChan TVar Bool
closed TVar Int
_slots TVar Int
_reads TChan a
_chan) =
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
closed Bool
True
isClosedTBMChan :: TBMChan a -> STM Bool
isClosedTBMChan :: forall a. TBMChan a -> STM Bool
isClosedTBMChan (TBMChan TVar Bool
closed TVar Int
_slots TVar Int
_reads TChan a
_chan) =
forall a. TVar a -> STM a
readTVar TVar Bool
closed
isEmptyTBMChan :: TBMChan a -> STM Bool
isEmptyTBMChan :: forall a. TBMChan a -> STM Bool
isEmptyTBMChan (TBMChan TVar Bool
_closed TVar Int
_slots TVar Int
_reads TChan a
chan) =
forall a. TChan a -> STM Bool
isEmptyTChan TChan a
chan
isFullTBMChan :: TBMChan a -> STM Bool
isFullTBMChan :: forall a. TBMChan a -> STM Bool
isFullTBMChan (TBMChan TVar Bool
_closed TVar Int
slots TVar Int
reads TChan a
_chan) = do
Int
n <- forall a. TVar a -> STM a
readTVar TVar Int
slots
if Int
n forall a. Ord a => a -> a -> Bool
<= Int
0
then do
Int
m <- forall a. TVar a -> STM a
readTVar TVar Int
reads
let n' :: Int
n' = Int
n forall a. Num a => a -> a -> a
+ Int
m
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
slots forall a b. (a -> b) -> a -> b
$! Int
n'
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
reads Int
0
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Int
n' forall a. Ord a => a -> a -> Bool
<= Int
0
else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
estimateFreeSlotsTBMChan :: TBMChan a -> STM Int
estimateFreeSlotsTBMChan :: forall a. TBMChan a -> STM Int
estimateFreeSlotsTBMChan (TBMChan TVar Bool
_closed TVar Int
slots TVar Int
reads TChan a
_chan) = do
Int
n <- forall a. TVar a -> STM a
readTVar TVar Int
slots
if Int
n forall a. Ord a => a -> a -> Bool
> Int
0
then forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
else do
Int
m <- forall a. TVar a -> STM a
readTVar TVar Int
reads
let n' :: Int
n' = Int
n forall a. Num a => a -> a -> a
+ Int
m
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
slots forall a b. (a -> b) -> a -> b
$! Int
n'
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
reads Int
0
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n'
freeSlotsTBMChan :: TBMChan a -> STM Int
freeSlotsTBMChan :: forall a. TBMChan a -> STM Int
freeSlotsTBMChan (TBMChan TVar Bool
_closed TVar Int
slots TVar Int
reads TChan a
_chan) = do
Int
n <- forall a. TVar a -> STM a
readTVar TVar Int
slots
Int
m <- forall a. TVar a -> STM a
readTVar TVar Int
reads
let n' :: Int
n' = Int
n forall a. Num a => a -> a -> a
+ Int
m
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
slots forall a b. (a -> b) -> a -> b
$! Int
n'
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
reads Int
0
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n'