module Control.Concurrent.STM.TBFQueue
( TBFQueue
, newTBFQueue
, newTBFQueueIO
, writeTBFQueue
, tryWriteTBFQueue
, readTBFQueue
, takeTBFQueue
, flushTBFQueue
, lengthTBFQueue
, isEmptyTBFQueue
) where
import Control.Concurrent.BQueue
import Control.Concurrent.STM
import Numeric.Natural
newtype TBFQueue a = TBFQueue (TVar (BQueue a))
newTBFQueue :: Natural
-> STM (TBFQueue a)
newTBFQueue bound = TBFQueue <$> newTVar (newBQueue (fromIntegral bound))
newTBFQueueIO :: Natural
-> IO (TBFQueue a)
newTBFQueueIO bound = TBFQueue <$> newTVarIO (newBQueue (fromIntegral bound))
writeTBFQueue :: TBFQueue a -> a -> STM ()
writeTBFQueue (TBFQueue bQueueTVar) x = do
bQueue <- readTVar bQueueTVar
case pushBQueue x bQueue of
Just newQueue -> writeTVar bQueueTVar newQueue
Nothing -> retry
tryWriteTBFQueue :: TBFQueue a -> a -> STM Bool
tryWriteTBFQueue (TBFQueue bQueueTVar) x = do
bQueue <- readTVar bQueueTVar
case pushBQueue x bQueue of
Just newQueue -> writeTVar bQueueTVar newQueue >> return True
Nothing -> return False
readTBFQueue :: TBFQueue a -> STM a
readTBFQueue (TBFQueue bQueueTVar) = do
bQueue <- readTVar bQueueTVar
case popBQueue bQueue of
Just (x, newQueue) -> writeTVar bQueueTVar newQueue >> return x
Nothing -> retry
flushTBFQueue :: TBFQueue a -> STM [a]
flushTBFQueue (TBFQueue bQueueTVar) = do
bQueue <- readTVar bQueueTVar
let (xs, newQueue) = flushBQueue bQueue
writeTVar bQueueTVar newQueue
return xs
takeTBFQueue :: Natural -> TBFQueue a -> STM [a]
takeTBFQueue i (TBFQueue bQueueTVar) = do
bQueue <- readTVar bQueueTVar
let (xs, newQueue) = takeBQueue (fromIntegral i) bQueue
writeTVar bQueueTVar newQueue
return xs
lengthTBFQueue :: TBFQueue a -> STM Natural
lengthTBFQueue (TBFQueue bQueueTVar) = fromIntegral . lengthBQueue <$> readTVar bQueueTVar
isEmptyTBFQueue :: TBFQueue a -> STM Bool
isEmptyTBFQueue = fmap (==0) . lengthTBFQueue