{-# 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
closed <- Bool -> STM (TVar Bool)
forall a. a -> STM (TVar a)
newTVar Bool
False
slots <- newTVar n
reads <- newTVar 0
chan <- newTChan
return (TBMChan closed slots reads chan)
newTBMChanIO :: Int -> IO (TBMChan a)
newTBMChanIO :: forall a. Int -> IO (TBMChan a)
newTBMChanIO Int
n = do
closed <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
slots <- newTVarIO n
reads <- newTVarIO 0
chan <- newTChanIO
return (TBMChan closed slots reads 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
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
if b
then do
mx <- tryReadTChan 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
mx
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
else do
x <- readTChan chan
modifyTVar' reads (1 +)
return (Just 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
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
if b
then do
mx <- tryReadTChan chan
case mx of
Maybe a
Nothing -> Maybe (Maybe a) -> STM (Maybe (Maybe a))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (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 (Maybe a) -> STM (Maybe (Maybe a))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just Maybe a
mx)
else do
mx <- tryReadTChan chan
case mx of
Maybe a
Nothing -> Maybe (Maybe a) -> STM (Maybe (Maybe a))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just Maybe a
mx)
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 (Maybe a) -> STM (Maybe (Maybe a))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> Maybe (Maybe a)
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
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
if b
then do
b' <- isEmptyTChan chan
if b'
then return Nothing
else Just <$> peekTChan chan
else Just <$> peekTChan 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
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
if b
then fmap Just <$> tryPeekTChan chan
else Just <$> tryPeekTChan 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
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
if b
then return ()
else do
n <- estimateFreeSlotsTBMChan self
if n <= 0
then retry
else do
writeTVar slots $! n - 1
writeTChan chan 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
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
if b
then return Nothing
else do
n <- estimateFreeSlotsTBMChan self
if n <= 0
then return (Just False)
else do
writeTVar slots $! n - 1
writeTChan chan x
return (Just 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
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
if b
then return ()
else do
modifyTVar' slots (subtract 1)
unGetTChan chan 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) =
TVar Bool -> Bool -> STM ()
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) =
TVar Bool -> STM Bool
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) =
TChan a -> STM Bool
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
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
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
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'
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
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'