module Control.Concurrent.Classy.STM.TBQueue
(
TBQueue
, newTBQueue
, readTBQueue
, tryReadTBQueue
, peekTBQueue
, tryPeekTBQueue
, writeTBQueue
, unGetTBQueue
, isEmptyTBQueue
, isFullTBQueue
) where
import Control.Monad.STM.Class
data TBQueue stm a
= TBQueue (TVar stm Int)
(TVar stm [a])
(TVar stm Int)
(TVar stm [a])
newTBQueue :: MonadSTM stm
=> Int
-> stm (TBQueue stm a)
newTBQueue size = do
readT <- newTVar []
writeT <- newTVar []
rsize <- newTVar 0
wsize <- newTVar size
pure (TBQueue rsize readT wsize writeT)
writeTBQueue :: MonadSTM stm => TBQueue stm a -> a -> stm ()
writeTBQueue (TBQueue rsize _ wsize writeT) a = do
w <- readTVar wsize
if w /= 0
then writeTVar wsize (w 1)
else do
r <- readTVar rsize
if r /= 0
then do
writeTVar rsize 0
writeTVar wsize (r 1)
else retry
listend <- readTVar writeT
writeTVar writeT (a:listend)
readTBQueue :: MonadSTM stm => TBQueue stm a -> stm a
readTBQueue (TBQueue rsize readT _ writeT) = do
xs <- readTVar readT
r <- readTVar rsize
writeTVar rsize (r + 1)
case xs of
(x:xs') -> do
writeTVar readT xs'
pure x
[] -> do
ys <- readTVar writeT
case ys of
[] -> retry
_ -> do
let (z:zs) = reverse ys
writeTVar writeT []
writeTVar readT zs
pure z
tryReadTBQueue :: MonadSTM stm => TBQueue stm a -> stm (Maybe a)
tryReadTBQueue c = (Just <$> readTBQueue c) `orElse` pure Nothing
peekTBQueue :: MonadSTM stm => TBQueue stm a -> stm a
peekTBQueue c = do
x <- readTBQueue c
unGetTBQueue c x
pure x
tryPeekTBQueue :: MonadSTM stm => TBQueue stm a -> stm (Maybe a)
tryPeekTBQueue c = do
m <- tryReadTBQueue c
case m of
Nothing -> pure Nothing
Just x -> do
unGetTBQueue c x
pure m
unGetTBQueue :: MonadSTM stm => TBQueue stm a -> a -> stm ()
unGetTBQueue (TBQueue rsize readT wsize _) a = do
r <- readTVar rsize
if r > 0
then writeTVar rsize (r 1)
else do
w <- readTVar wsize
if w > 0
then writeTVar wsize (w 1)
else retry
xs <- readTVar readT
writeTVar readT (a:xs)
isEmptyTBQueue :: MonadSTM stm => TBQueue stm a -> stm Bool
isEmptyTBQueue (TBQueue _ readT _ writeT) = do
xs <- readTVar readT
case xs of
(_:_) -> pure False
[] -> null <$> readTVar writeT
isFullTBQueue :: MonadSTM stm => TBQueue stm a -> stm Bool
isFullTBQueue (TBQueue rsize _ wsize _) = do
w <- readTVar wsize
if w > 0
then pure False
else (>0) <$> readTVar rsize