{-# 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
closed <- Bool -> STM (TVar Bool)
forall a. a -> STM (TVar a)
newTVar Bool
False
slots <- newTVar n
reads <- newTVar 0
queue <- newTQueue
return (TBMQueue closed slots reads queue)
newTBMQueueIO :: Int -> IO (TBMQueue a)
newTBMQueueIO :: forall a. Int -> IO (TBMQueue a)
newTBMQueueIO Int
n = do
closed <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
False
slots <- newTVarIO n
reads <- newTVarIO 0
queue <- newTQueueIO
return (TBMQueue closed slots reads 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
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
if b
then do
mx <- tryReadTQueue queue
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 <- readTQueue queue
modifyTVar' reads (1 +)
return (Just 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
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
if b
then do
mx <- tryReadTQueue queue
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 <- tryReadTQueue queue
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)
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
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
if b
then do
b' <- isEmptyTQueue queue
if b'
then return Nothing
else Just <$> peekTQueue queue
else Just <$> peekTQueue 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
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
if b
then fmap Just <$> tryPeekTQueue queue
else Just <$> tryPeekTQueue 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
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
if b
then return ()
else do
n <- estimateFreeSlotsTBMQueue self
if n <= 0
then retry
else do
writeTVar slots $! n - 1
writeTQueue queue 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
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
closed
if b
then return Nothing
else do
n <- estimateFreeSlotsTBMQueue self
if n <= 0
then return (Just False)
else do
writeTVar slots $! n - 1
writeTQueue queue x
return (Just 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
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)
unGetTQueue queue 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) =
TVar Bool -> Bool -> STM ()
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) =
TVar Bool -> STM Bool
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) =
TQueue a -> STM Bool
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
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
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
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'
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
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'