{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif
module Control.Concurrent.STM.TBQueue (
TBQueue,
newTBQueue,
newTBQueueIO,
readTBQueue,
tryReadTBQueue,
flushTBQueue,
peekTBQueue,
tryPeekTBQueue,
writeTBQueue,
unGetTBQueue,
lengthTBQueue,
isEmptyTBQueue,
isFullTBQueue,
) where
import Data.Typeable (Typeable)
import GHC.Conc (STM, TVar, newTVar, newTVarIO, orElse,
readTVar, retry, writeTVar)
import Numeric.Natural (Natural)
import Prelude hiding (read)
data TBQueue a
= TBQueue {-# UNPACK #-} !(TVar Natural)
{-# UNPACK #-} !(TVar [a])
{-# UNPACK #-} !(TVar Natural)
{-# UNPACK #-} !(TVar [a])
!(Natural)
deriving Typeable
instance Eq (TBQueue a) where
TBQueue TVar Natural
a TVar [a]
_ TVar Natural
_ TVar [a]
_ Natural
_ == :: TBQueue a -> TBQueue a -> Bool
== TBQueue TVar Natural
b TVar [a]
_ TVar Natural
_ TVar [a]
_ Natural
_ = TVar Natural
a forall a. Eq a => a -> a -> Bool
== TVar Natural
b
newTBQueue :: Natural
-> STM (TBQueue a)
newTBQueue :: forall a. Natural -> STM (TBQueue a)
newTBQueue Natural
size = do
TVar [a]
read <- forall a. a -> STM (TVar a)
newTVar []
TVar [a]
write <- forall a. a -> STM (TVar a)
newTVar []
TVar Natural
rsize <- forall a. a -> STM (TVar a)
newTVar Natural
0
TVar Natural
wsize <- forall a. a -> STM (TVar a)
newTVar Natural
size
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a.
TVar Natural
-> TVar [a] -> TVar Natural -> TVar [a] -> Natural -> TBQueue a
TBQueue TVar Natural
rsize TVar [a]
read TVar Natural
wsize TVar [a]
write Natural
size)
newTBQueueIO :: Natural -> IO (TBQueue a)
newTBQueueIO :: forall a. Natural -> IO (TBQueue a)
newTBQueueIO Natural
size = do
TVar [a]
read <- forall a. a -> IO (TVar a)
newTVarIO []
TVar [a]
write <- forall a. a -> IO (TVar a)
newTVarIO []
TVar Natural
rsize <- forall a. a -> IO (TVar a)
newTVarIO Natural
0
TVar Natural
wsize <- forall a. a -> IO (TVar a)
newTVarIO Natural
size
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a.
TVar Natural
-> TVar [a] -> TVar Natural -> TVar [a] -> Natural -> TBQueue a
TBQueue TVar Natural
rsize TVar [a]
read TVar Natural
wsize TVar [a]
write Natural
size)
writeTBQueue :: TBQueue a -> a -> STM ()
writeTBQueue :: forall a. TBQueue a -> a -> STM ()
writeTBQueue (TBQueue TVar Natural
rsize TVar [a]
_read TVar Natural
wsize TVar [a]
write Natural
_size) a
a = do
Natural
w <- forall a. TVar a -> STM a
readTVar TVar Natural
wsize
if (Natural
w forall a. Ord a => a -> a -> Bool
> Natural
0)
then do forall a. TVar a -> a -> STM ()
writeTVar TVar Natural
wsize forall a b. (a -> b) -> a -> b
$! Natural
w forall a. Num a => a -> a -> a
- Natural
1
else do
Natural
r <- forall a. TVar a -> STM a
readTVar TVar Natural
rsize
if (Natural
r forall a. Ord a => a -> a -> Bool
> Natural
0)
then do forall a. TVar a -> a -> STM ()
writeTVar TVar Natural
rsize Natural
0
forall a. TVar a -> a -> STM ()
writeTVar TVar Natural
wsize forall a b. (a -> b) -> a -> b
$! Natural
r forall a. Num a => a -> a -> a
- Natural
1
else forall a. STM a
retry
[a]
listend <- forall a. TVar a -> STM a
readTVar TVar [a]
write
forall a. TVar a -> a -> STM ()
writeTVar TVar [a]
write (a
aforall a. a -> [a] -> [a]
:[a]
listend)
readTBQueue :: TBQueue a -> STM a
readTBQueue :: forall a. TBQueue a -> STM a
readTBQueue (TBQueue TVar Natural
rsize TVar [a]
read TVar Natural
_wsize TVar [a]
write Natural
_size) = do
[a]
xs <- forall a. TVar a -> STM a
readTVar TVar [a]
read
Natural
r <- forall a. TVar a -> STM a
readTVar TVar Natural
rsize
forall a. TVar a -> a -> STM ()
writeTVar TVar Natural
rsize forall a b. (a -> b) -> a -> b
$! Natural
r forall a. Num a => a -> a -> a
+ Natural
1
case [a]
xs of
(a
x:[a]
xs') -> do
forall a. TVar a -> a -> STM ()
writeTVar TVar [a]
read [a]
xs'
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
[] -> do
[a]
ys <- forall a. TVar a -> STM a
readTVar TVar [a]
write
case [a]
ys of
[] -> forall a. STM a
retry
[a]
_ -> do
let ~(a
z,[a]
zs) = case forall a. [a] -> [a]
reverse [a]
ys of
a
z':[a]
zs' -> (a
z',[a]
zs')
[a]
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"readTBQueue: impossible"
forall a. TVar a -> a -> STM ()
writeTVar TVar [a]
write []
forall a. TVar a -> a -> STM ()
writeTVar TVar [a]
read [a]
zs
forall (m :: * -> *) a. Monad m => a -> m a
return a
z
tryReadTBQueue :: TBQueue a -> STM (Maybe a)
tryReadTBQueue :: forall a. TBQueue a -> STM (Maybe a)
tryReadTBQueue TBQueue a
c = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just (forall a. TBQueue a -> STM a
readTBQueue TBQueue a
c) forall a. STM a -> STM a -> STM a
`orElse` forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
flushTBQueue :: TBQueue a -> STM [a]
flushTBQueue :: forall a. TBQueue a -> STM [a]
flushTBQueue (TBQueue TVar Natural
rsize TVar [a]
read TVar Natural
wsize TVar [a]
write Natural
size) = do
[a]
xs <- forall a. TVar a -> STM a
readTVar TVar [a]
read
[a]
ys <- forall a. TVar a -> STM a
readTVar TVar [a]
write
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
ys
then forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
forall a. TVar a -> a -> STM ()
writeTVar TVar [a]
read []
forall a. TVar a -> a -> STM ()
writeTVar TVar [a]
write []
forall a. TVar a -> a -> STM ()
writeTVar TVar Natural
rsize Natural
0
forall a. TVar a -> a -> STM ()
writeTVar TVar Natural
wsize Natural
size
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
xs forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
reverse [a]
ys)
peekTBQueue :: TBQueue a -> STM a
peekTBQueue :: forall a. TBQueue a -> STM a
peekTBQueue (TBQueue TVar Natural
_ TVar [a]
read TVar Natural
_ TVar [a]
write Natural
_) = do
[a]
xs <- forall a. TVar a -> STM a
readTVar TVar [a]
read
case [a]
xs of
(a
x:[a]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return a
x
[] -> do
[a]
ys <- forall a. TVar a -> STM a
readTVar TVar [a]
write
case [a]
ys of
[] -> forall a. STM a
retry
[a]
_ -> do
let (a
z:[a]
zs) = forall a. [a] -> [a]
reverse [a]
ys
forall a. TVar a -> a -> STM ()
writeTVar TVar [a]
write []
forall a. TVar a -> a -> STM ()
writeTVar TVar [a]
read (a
zforall a. a -> [a] -> [a]
:[a]
zs)
forall (m :: * -> *) a. Monad m => a -> m a
return a
z
tryPeekTBQueue :: TBQueue a -> STM (Maybe a)
tryPeekTBQueue :: forall a. TBQueue a -> STM (Maybe a)
tryPeekTBQueue TBQueue a
c = do
Maybe a
m <- forall a. TBQueue a -> STM (Maybe a)
tryReadTBQueue TBQueue a
c
case Maybe a
m of
Maybe a
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just a
x -> do
forall a. TBQueue a -> a -> STM ()
unGetTBQueue TBQueue a
c a
x
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
m
unGetTBQueue :: TBQueue a -> a -> STM ()
unGetTBQueue :: forall a. TBQueue a -> a -> STM ()
unGetTBQueue (TBQueue TVar Natural
rsize TVar [a]
read TVar Natural
wsize TVar [a]
_write Natural
_size) a
a = do
Natural
r <- forall a. TVar a -> STM a
readTVar TVar Natural
rsize
if (Natural
r forall a. Ord a => a -> a -> Bool
> Natural
0)
then do forall a. TVar a -> a -> STM ()
writeTVar TVar Natural
rsize forall a b. (a -> b) -> a -> b
$! Natural
r forall a. Num a => a -> a -> a
- Natural
1
else do
Natural
w <- forall a. TVar a -> STM a
readTVar TVar Natural
wsize
if (Natural
w forall a. Ord a => a -> a -> Bool
> Natural
0)
then forall a. TVar a -> a -> STM ()
writeTVar TVar Natural
wsize forall a b. (a -> b) -> a -> b
$! Natural
w forall a. Num a => a -> a -> a
- Natural
1
else forall a. STM a
retry
[a]
xs <- forall a. TVar a -> STM a
readTVar TVar [a]
read
forall a. TVar a -> a -> STM ()
writeTVar TVar [a]
read (a
aforall a. a -> [a] -> [a]
:[a]
xs)
lengthTBQueue :: TBQueue a -> STM Natural
lengthTBQueue :: forall a. TBQueue a -> STM Natural
lengthTBQueue (TBQueue TVar Natural
rsize TVar [a]
_read TVar Natural
wsize TVar [a]
_write Natural
size) = do
Natural
r <- forall a. TVar a -> STM a
readTVar TVar Natural
rsize
Natural
w <- forall a. TVar a -> STM a
readTVar TVar Natural
wsize
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Natural
size forall a. Num a => a -> a -> a
- Natural
r forall a. Num a => a -> a -> a
- Natural
w
isEmptyTBQueue :: TBQueue a -> STM Bool
isEmptyTBQueue :: forall a. TBQueue a -> STM Bool
isEmptyTBQueue (TBQueue TVar Natural
_rsize TVar [a]
read TVar Natural
_wsize TVar [a]
write Natural
_size) = do
[a]
xs <- forall a. TVar a -> STM a
readTVar TVar [a]
read
case [a]
xs of
(a
_:[a]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
[] -> do [a]
ys <- forall a. TVar a -> STM a
readTVar TVar [a]
write
case [a]
ys of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
[a]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
isFullTBQueue :: TBQueue a -> STM Bool
isFullTBQueue :: forall a. TBQueue a -> STM Bool
isFullTBQueue (TBQueue TVar Natural
rsize TVar [a]
_read TVar Natural
wsize TVar [a]
_write Natural
_size) = do
Natural
w <- forall a. TVar a -> STM a
readTVar TVar Natural
wsize
if (Natural
w forall a. Ord a => a -> a -> Bool
> Natural
0)
then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
else do
Natural
r <- forall a. TVar a -> STM a
readTVar TVar Natural
rsize
if (Natural
r forall a. Ord a => a -> a -> Bool
> Natural
0)
then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True