{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# LANGUAGE CPP, DeriveDataTypeable #-}
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif
module Control.Concurrent.STM.TBQueue (
TBQueue,
newTBQueue,
newTBQueueIO,
readTBQueue,
tryReadTBQueue,
flushTBQueue,
peekTBQueue,
tryPeekTBQueue,
writeTBQueue,
unGetTBQueue,
isEmptyTBQueue,
isFullTBQueue,
) where
import Data.Typeable
import GHC.Conc
#define _UPK_(x) {-# UNPACK #-} !(x)
data TBQueue a
= TBQueue _UPK_(TVar Int)
_UPK_(TVar [a])
_UPK_(TVar Int)
_UPK_(TVar [a])
_UPK_(Int)
deriving Typeable
instance Eq (TBQueue a) where
TBQueue a _ _ _ _ == TBQueue b _ _ _ _ = a == b
newTBQueue :: Int
-> STM (TBQueue a)
newTBQueue size = do
read <- newTVar []
write <- newTVar []
rsize <- newTVar 0
wsize <- newTVar size
return (TBQueue rsize read wsize write size)
newTBQueueIO :: Int -> IO (TBQueue a)
newTBQueueIO size = do
read <- newTVarIO []
write <- newTVarIO []
rsize <- newTVarIO 0
wsize <- newTVarIO size
return (TBQueue rsize read wsize write size)
writeTBQueue :: TBQueue a -> a -> STM ()
writeTBQueue (TBQueue rsize _read wsize write _size) a = do
w <- readTVar wsize
if (w /= 0)
then do 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 write
writeTVar write (a:listend)
readTBQueue :: TBQueue a -> STM a
readTBQueue (TBQueue rsize read _wsize write _size) = do
xs <- readTVar read
r <- readTVar rsize
writeTVar rsize $! r + 1
case xs of
(x:xs') -> do
writeTVar read xs'
return x
[] -> do
ys <- readTVar write
case ys of
[] -> retry
_ -> do
let (z:zs) = reverse ys
writeTVar write []
writeTVar read zs
return z
tryReadTBQueue :: TBQueue a -> STM (Maybe a)
tryReadTBQueue c = fmap Just (readTBQueue c) `orElse` return Nothing
flushTBQueue :: TBQueue a -> STM [a]
flushTBQueue (TBQueue rsize read wsize write size) = do
xs <- readTVar read
ys <- readTVar write
if null xs && null ys
then return []
else do
writeTVar read []
writeTVar write []
writeTVar rsize 0
writeTVar wsize size
return (xs ++ reverse ys)
peekTBQueue :: TBQueue a -> STM a
peekTBQueue c = do
x <- readTBQueue c
unGetTBQueue c x
return x
tryPeekTBQueue :: TBQueue a -> STM (Maybe a)
tryPeekTBQueue c = do
m <- tryReadTBQueue c
case m of
Nothing -> return Nothing
Just x -> do
unGetTBQueue c x
return m
unGetTBQueue :: TBQueue a -> a -> STM ()
unGetTBQueue (TBQueue rsize read wsize _write _size) a = do
r <- readTVar rsize
if (r > 0)
then do writeTVar rsize $! r - 1
else do
w <- readTVar wsize
if (w > 0)
then writeTVar wsize $! w - 1
else retry
xs <- readTVar read
writeTVar read (a:xs)
isEmptyTBQueue :: TBQueue a -> STM Bool
isEmptyTBQueue (TBQueue _rsize read _wsize write _size) = do
xs <- readTVar read
case xs of
(_:_) -> return False
[] -> do ys <- readTVar write
case ys of
[] -> return True
_ -> return False
isFullTBQueue :: TBQueue a -> STM Bool
isFullTBQueue (TBQueue rsize _read wsize _write _size) = do
w <- readTVar wsize
if (w > 0)
then return False
else do
r <- readTVar rsize
if (r > 0)
then return False
else return True