{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
{-# LANGUAGE CPP, DeriveDataTypeable #-}
#ifdef __HADDOCK__
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
#endif
#if __GLASGOW_HASKELL__ >= 701
# ifdef __HADDOCK__
{-# LANGUAGE Trustworthy #-}
# else
{-# LANGUAGE Safe #-}
# endif
#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
#ifdef __HADDOCK__
import Control.Monad.STM (atomically)
import System.IO.Unsafe (unsafePerformIO)
#endif
data TBMQueue a = TBMQueue
{-# UNPACK #-} !(TVar Bool)
{-# UNPACK #-} !(TVar Int)
{-# UNPACK #-} !(TVar Int)
{-# UNPACK #-} !(TQueue a)
deriving (Typeable)
newTBMQueue :: Int -> STM (TBMQueue a)
newTBMQueue :: Int -> STM (TBMQueue a)
newTBMQueue n :: Int
n = do
TVar Bool
closed <- Bool -> STM (TVar Bool)
forall a. a -> STM (TVar a)
newTVar Bool
False
TVar Int
slots <- Int -> STM (TVar Int)
forall a. a -> STM (TVar a)
newTVar Int
n
TVar Int
reads <- Int -> STM (TVar Int)
forall a. a -> STM (TVar a)
newTVar 0
TQueue a
queue <- STM (TQueue a)
forall a. STM (TQueue a)
newTQueue
TBMQueue a -> STM (TBMQueue a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar Bool -> TVar Int -> TVar Int -> TQueue a -> TBMQueue a
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 :: Int -> IO (TBMQueue a)
newTBMQueueIO n :: Int
n = do
TVar Bool
closed <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
TVar Int
slots <- Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
n
TVar Int
reads <- Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO 0
TQueue a
queue <- IO (TQueue a)
forall a. IO (TQueue a)
newTQueueIO
TBMQueue a -> IO (TBMQueue a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar Bool -> TVar Int -> TVar Int -> TQueue a -> TBMQueue a
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 :: TBMQueue a -> STM (Maybe a)
readTBMQueue (TBMQueue closed :: TVar Bool
closed _slots :: TVar Int
_slots reads :: TVar Int
reads queue :: TQueue a
queue) = do
Bool
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
if Bool
b
then do
Maybe a
mx <- TQueue a -> STM (Maybe a)
forall a. TQueue a -> STM (Maybe a)
tryReadTQueue TQueue a
queue
case Maybe a
mx of
Nothing -> Maybe a -> STM (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
mx
Just _x :: a
_x -> do
TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
reads (1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+)
Maybe a -> STM (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
mx
else do
a
x <- TQueue a -> STM a
forall a. TQueue a -> STM a
readTQueue TQueue a
queue
TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
reads (1 Int -> Int -> Int
forall a. Num a => a -> a -> 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
x)
tryReadTBMQueue :: TBMQueue a -> STM (Maybe (Maybe a))
tryReadTBMQueue :: TBMQueue a -> STM (Maybe (Maybe a))
tryReadTBMQueue (TBMQueue closed :: TVar Bool
closed _slots :: TVar Int
_slots reads :: TVar Int
reads queue :: TQueue a
queue) = do
Bool
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
if Bool
b
then do
Maybe a
mx <- TQueue a -> STM (Maybe a)
forall a. TQueue a -> STM (Maybe a)
tryReadTQueue TQueue a
queue
case Maybe a
mx of
Nothing -> Maybe (Maybe a) -> STM (Maybe (Maybe a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Maybe a)
forall a. Maybe a
Nothing
Just _x :: a
_x -> do
TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
reads (1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+)
Maybe (Maybe a) -> STM (Maybe (Maybe 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
Maybe a
mx <- TQueue a -> STM (Maybe a)
forall a. TQueue a -> STM (Maybe a)
tryReadTQueue TQueue a
queue
case Maybe a
mx of
Nothing -> Maybe (Maybe a) -> STM (Maybe (Maybe 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 _x :: a
_x -> do
TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
reads (1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+)
Maybe (Maybe a) -> STM (Maybe (Maybe a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just Maybe a
mx)
peekTBMQueue :: TBMQueue a -> STM (Maybe a)
peekTBMQueue :: TBMQueue a -> STM (Maybe a)
peekTBMQueue (TBMQueue closed :: TVar Bool
closed _slots :: TVar Int
_slots _reads :: TVar Int
_reads queue :: TQueue a
queue) = do
Bool
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
if Bool
b
then do
Bool
b' <- TQueue a -> STM Bool
forall a. TQueue a -> STM Bool
isEmptyTQueue TQueue a
queue
if Bool
b'
then Maybe a -> STM (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
else a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> STM a -> STM (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TQueue a -> STM a
forall a. TQueue a -> STM a
peekTQueue TQueue a
queue
else a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> STM a -> STM (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TQueue a -> STM a
forall a. TQueue a -> STM a
peekTQueue TQueue a
queue
tryPeekTBMQueue :: TBMQueue a -> STM (Maybe (Maybe a))
tryPeekTBMQueue :: TBMQueue a -> STM (Maybe (Maybe a))
tryPeekTBMQueue (TBMQueue closed :: TVar Bool
closed _slots :: TVar Int
_slots _reads :: TVar Int
_reads queue :: TQueue a
queue) = do
Bool
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
if Bool
b
then (a -> Maybe a) -> Maybe a -> Maybe (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (Maybe a -> Maybe (Maybe a))
-> STM (Maybe a) -> STM (Maybe (Maybe a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TQueue a -> STM (Maybe a)
forall a. TQueue a -> STM (Maybe a)
tryPeekTQueue TQueue a
queue
else Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just (Maybe a -> Maybe (Maybe a))
-> STM (Maybe a) -> STM (Maybe (Maybe a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TQueue a -> STM (Maybe a)
forall a. TQueue a -> STM (Maybe a)
tryPeekTQueue TQueue a
queue
writeTBMQueue :: TBMQueue a -> a -> STM ()
writeTBMQueue :: TBMQueue a -> a -> STM ()
writeTBMQueue self :: TBMQueue a
self@(TBMQueue closed :: TVar Bool
closed slots :: TVar Int
slots _reads :: TVar Int
_reads queue :: TQueue a
queue) x :: a
x = do
Bool
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
if Bool
b
then () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do
Int
n <- TBMQueue a -> STM Int
forall a. TBMQueue a -> STM Int
estimateFreeSlotsTBMQueue TBMQueue a
self
if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0
then STM ()
forall a. STM a
retry
else do
TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
slots (Int -> STM ()) -> Int -> STM ()
forall a b. (a -> b) -> a -> b
$! Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
TQueue a -> a -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue a
queue a
x
tryWriteTBMQueue :: TBMQueue a -> a -> STM (Maybe Bool)
tryWriteTBMQueue :: TBMQueue a -> a -> STM (Maybe Bool)
tryWriteTBMQueue self :: TBMQueue a
self@(TBMQueue closed :: TVar Bool
closed slots :: TVar Int
slots _reads :: TVar Int
_reads queue :: TQueue a
queue) x :: a
x = do
Bool
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
if Bool
b
then Maybe Bool -> STM (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bool
forall a. Maybe a
Nothing
else do
Int
n <- TBMQueue a -> STM Int
forall a. TBMQueue a -> STM Int
estimateFreeSlotsTBMQueue TBMQueue a
self
if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0
then Maybe Bool -> STM (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False)
else do
TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
slots (Int -> STM ()) -> Int -> STM ()
forall a b. (a -> b) -> a -> b
$! Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
TQueue a -> a -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue a
queue a
x
Maybe Bool -> STM (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)
unGetTBMQueue :: TBMQueue a -> a -> STM ()
unGetTBMQueue :: TBMQueue a -> a -> STM ()
unGetTBMQueue (TBMQueue closed :: TVar Bool
closed slots :: TVar Int
slots _reads :: TVar Int
_reads queue :: TQueue a
queue) x :: a
x = do
Bool
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
if Bool
b
then () -> STM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else 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 1)
TQueue a -> a -> STM ()
forall a. TQueue a -> a -> STM ()
unGetTQueue TQueue a
queue a
x
closeTBMQueue :: TBMQueue a -> STM ()
closeTBMQueue :: TBMQueue a -> STM ()
closeTBMQueue (TBMQueue closed :: TVar Bool
closed _slots :: TVar Int
_slots _reads :: TVar Int
_reads _queue :: TQueue a
_queue) =
TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
closed Bool
True
isClosedTBMQueue :: TBMQueue a -> STM Bool
isClosedTBMQueue :: TBMQueue a -> STM Bool
isClosedTBMQueue (TBMQueue closed :: TVar Bool
closed _slots :: TVar Int
_slots _reads :: TVar Int
_reads _queue :: TQueue a
_queue) =
TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
isEmptyTBMQueue :: TBMQueue a -> STM Bool
isEmptyTBMQueue :: TBMQueue a -> STM Bool
isEmptyTBMQueue (TBMQueue _closed :: TVar Bool
_closed _slots :: TVar Int
_slots _reads :: TVar Int
_reads queue :: TQueue a
queue) =
TQueue a -> STM Bool
forall a. TQueue a -> STM Bool
isEmptyTQueue TQueue a
queue
isFullTBMQueue :: TBMQueue a -> STM Bool
isFullTBMQueue :: TBMQueue a -> STM Bool
isFullTBMQueue (TBMQueue _closed :: TVar Bool
_closed slots :: TVar Int
slots reads :: TVar Int
reads _queue :: TQueue a
_queue) = do
Int
n <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
slots
if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0
then do
Int
m <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
reads
let n' :: Int
n' = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m
TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
slots (Int -> STM ()) -> Int -> STM ()
forall a b. (a -> b) -> a -> b
$! Int
n'
TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
reads 0
Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> STM Bool) -> Bool -> STM Bool
forall a b. (a -> b) -> a -> b
$! Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0
else Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
estimateFreeSlotsTBMQueue :: TBMQueue a -> STM Int
estimateFreeSlotsTBMQueue :: TBMQueue a -> STM Int
estimateFreeSlotsTBMQueue (TBMQueue _closed :: TVar Bool
_closed slots :: TVar Int
slots reads :: TVar Int
reads _queue :: TQueue a
_queue) = do
Int
n <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
slots
if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0
then Int -> STM Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
else do
Int
m <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
reads
let n' :: Int
n' = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m
TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
slots (Int -> STM ()) -> Int -> STM ()
forall a b. (a -> b) -> a -> b
$! Int
n'
TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
reads 0
Int -> STM Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n'
freeSlotsTBMQueue :: TBMQueue a -> STM Int
freeSlotsTBMQueue :: TBMQueue a -> STM Int
freeSlotsTBMQueue (TBMQueue _closed :: TVar Bool
_closed slots :: TVar Int
slots reads :: TVar Int
reads _queue :: TQueue a
_queue) = do
Int
n <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
slots
Int
m <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
reads
let n' :: Int
n' = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m
TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
slots (Int -> STM ()) -> Int -> STM ()
forall a b. (a -> b) -> a -> b
$! Int
n'
TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
reads 0
Int -> STM Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n'