{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
{-# LANGUAGE CPP, DeriveDataTypeable #-}
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
#endif
module Control.Concurrent.STM.TBMQueue
(
TBMQueue()
, newTBMQueue
, newTBMQueueIO
, readTBMQueue
, tryReadTBMQueue
, peekTBMQueue
, tryPeekTBMQueue
, writeTBMQueue
, tryWriteTBMQueue
, unGetTBMQueue
, closeTBMQueue
, isClosedTBMQueue
, isEmptyTBMQueue
, isFullTBMQueue
, estimateFreeSlotsTBMQueue
, freeSlotsTBMQueue
) 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.TQueue
data TBMQueue a = TBMQueue
{-# UNPACK #-} !(TVar Bool)
{-# UNPACK #-} !(TVar Int)
{-# UNPACK #-} !(TVar Int)
{-# UNPACK #-} !(TQueue a)
deriving (Typeable)
newTBMQueue :: Int -> STM (TBMQueue a)
newTBMQueue :: forall a. Int -> STM (TBMQueue a)
newTBMQueue 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
TQueue a
queue <- forall a. STM (TQueue a)
newTQueue
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a.
TVar Bool -> TVar Int -> TVar Int -> TQueue a -> TBMQueue a
TBMQueue TVar Bool
closed TVar Int
slots TVar Int
reads TQueue a
queue)
newTBMQueueIO :: Int -> IO (TBMQueue a)
newTBMQueueIO :: forall a. Int -> IO (TBMQueue a)
newTBMQueueIO 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
TQueue a
queue <- forall a. IO (TQueue a)
newTQueueIO
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a.
TVar Bool -> TVar Int -> TVar Int -> TQueue a -> TBMQueue a
TBMQueue TVar Bool
closed TVar Int
slots TVar Int
reads TQueue a
queue)
readTBMQueue :: TBMQueue a -> STM (Maybe a)
readTBMQueue :: forall a. TBMQueue a -> STM (Maybe a)
readTBMQueue (TBMQueue TVar Bool
closed TVar Int
_slots TVar Int
reads TQueue a
queue) = do
Bool
b <- forall a. TVar a -> STM a
readTVar TVar Bool
closed
if Bool
b
then do
Maybe a
mx <- forall a. TQueue a -> STM (Maybe a)
tryReadTQueue TQueue a
queue
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. TQueue a -> STM a
readTQueue TQueue a
queue
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)
tryReadTBMQueue :: TBMQueue a -> STM (Maybe (Maybe a))
tryReadTBMQueue :: forall a. TBMQueue a -> STM (Maybe (Maybe a))
tryReadTBMQueue (TBMQueue TVar Bool
closed TVar Int
_slots TVar Int
reads TQueue a
queue) = do
Bool
b <- forall a. TVar a -> STM a
readTVar TVar Bool
closed
if Bool
b
then do
Maybe a
mx <- forall a. TQueue a -> STM (Maybe a)
tryReadTQueue TQueue a
queue
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. TQueue a -> STM (Maybe a)
tryReadTQueue TQueue a
queue
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)
peekTBMQueue :: TBMQueue a -> STM (Maybe a)
peekTBMQueue :: forall a. TBMQueue a -> STM (Maybe a)
peekTBMQueue (TBMQueue TVar Bool
closed TVar Int
_slots TVar Int
_reads TQueue a
queue) = do
Bool
b <- forall a. TVar a -> STM a
readTVar TVar Bool
closed
if Bool
b
then do
Bool
b' <- forall a. TQueue a -> STM Bool
isEmptyTQueue TQueue a
queue
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. TQueue a -> STM a
peekTQueue TQueue a
queue
else forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TQueue a -> STM a
peekTQueue TQueue a
queue
tryPeekTBMQueue :: TBMQueue a -> STM (Maybe (Maybe a))
tryPeekTBMQueue :: forall a. TBMQueue a -> STM (Maybe (Maybe a))
tryPeekTBMQueue (TBMQueue TVar Bool
closed TVar Int
_slots TVar Int
_reads TQueue a
queue) = 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. TQueue a -> STM (Maybe a)
tryPeekTQueue TQueue a
queue
else forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TQueue a -> STM (Maybe a)
tryPeekTQueue TQueue a
queue
writeTBMQueue :: TBMQueue a -> a -> STM ()
writeTBMQueue :: forall a. TBMQueue a -> a -> STM ()
writeTBMQueue self :: TBMQueue a
self@(TBMQueue TVar Bool
closed TVar Int
slots TVar Int
_reads TQueue a
queue) 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. TBMQueue a -> STM Int
estimateFreeSlotsTBMQueue TBMQueue 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. TQueue a -> a -> STM ()
writeTQueue TQueue a
queue a
x
tryWriteTBMQueue :: TBMQueue a -> a -> STM (Maybe Bool)
tryWriteTBMQueue :: forall a. TBMQueue a -> a -> STM (Maybe Bool)
tryWriteTBMQueue self :: TBMQueue a
self@(TBMQueue TVar Bool
closed TVar Int
slots TVar Int
_reads TQueue a
queue) 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. TBMQueue a -> STM Int
estimateFreeSlotsTBMQueue TBMQueue 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. TQueue a -> a -> STM ()
writeTQueue TQueue a
queue a
x
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Bool
True)
unGetTBMQueue :: TBMQueue a -> a -> STM ()
unGetTBMQueue :: forall a. TBMQueue a -> a -> STM ()
unGetTBMQueue (TBMQueue TVar Bool
closed TVar Int
slots TVar Int
_reads TQueue a
queue) 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. TQueue a -> a -> STM ()
unGetTQueue TQueue a
queue a
x
closeTBMQueue :: TBMQueue a -> STM ()
closeTBMQueue :: forall a. TBMQueue a -> STM ()
closeTBMQueue (TBMQueue TVar Bool
closed TVar Int
_slots TVar Int
_reads TQueue a
_queue) =
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
closed Bool
True
isClosedTBMQueue :: TBMQueue a -> STM Bool
isClosedTBMQueue :: forall a. TBMQueue a -> STM Bool
isClosedTBMQueue (TBMQueue TVar Bool
closed TVar Int
_slots TVar Int
_reads TQueue a
_queue) =
forall a. TVar a -> STM a
readTVar TVar Bool
closed
isEmptyTBMQueue :: TBMQueue a -> STM Bool
isEmptyTBMQueue :: forall a. TBMQueue a -> STM Bool
isEmptyTBMQueue (TBMQueue TVar Bool
_closed TVar Int
_slots TVar Int
_reads TQueue a
queue) =
forall a. TQueue a -> STM Bool
isEmptyTQueue TQueue a
queue
isFullTBMQueue :: TBMQueue a -> STM Bool
isFullTBMQueue :: forall a. TBMQueue a -> STM Bool
isFullTBMQueue (TBMQueue TVar Bool
_closed TVar Int
slots TVar Int
reads TQueue a
_queue) = 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
estimateFreeSlotsTBMQueue :: TBMQueue a -> STM Int
estimateFreeSlotsTBMQueue :: forall a. TBMQueue a -> STM Int
estimateFreeSlotsTBMQueue (TBMQueue TVar Bool
_closed TVar Int
slots TVar Int
reads TQueue a
_queue) = 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'
freeSlotsTBMQueue :: TBMQueue a -> STM Int
freeSlotsTBMQueue :: forall a. TBMQueue a -> STM Int
freeSlotsTBMQueue (TBMQueue TVar Bool
_closed TVar Int
slots TVar Int
reads TQueue a
_queue) = 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'