module Control.Concurrent.Classy.STM.TBQueue
(
TBQueue
, newTBQueue
, readTBQueue
, tryReadTBQueue
, flushTBQueue
, peekTBQueue
, tryPeekTBQueue
, writeTBQueue
, unGetTBQueue
, lengthTBQueue
, isEmptyTBQueue
, isFullTBQueue
) where
import Control.Monad.STM.Class
import Numeric.Natural
data TBQueue stm a
= TBQueue (TVar stm Natural)
(TVar stm [a])
(TVar stm Natural)
(TVar stm [a])
!Natural
newTBQueue :: MonadSTM stm
=> Natural
-> stm (TBQueue stm a)
newTBQueue :: Natural -> stm (TBQueue stm a)
newTBQueue Natural
size = do
TVar stm [a]
readT <- [a] -> stm (TVar stm [a])
forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar []
TVar stm [a]
writeT <- [a] -> stm (TVar stm [a])
forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar []
TVar stm Natural
rsize <- Natural -> stm (TVar stm Natural)
forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar Natural
0
TVar stm Natural
wsize <- Natural -> stm (TVar stm Natural)
forall (stm :: * -> *) a. MonadSTM stm => a -> stm (TVar stm a)
newTVar Natural
size
TBQueue stm a -> stm (TBQueue stm a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TVar stm Natural
-> TVar stm [a]
-> TVar stm Natural
-> TVar stm [a]
-> Natural
-> TBQueue stm a
forall (stm :: * -> *) a.
TVar stm Natural
-> TVar stm [a]
-> TVar stm Natural
-> TVar stm [a]
-> Natural
-> TBQueue stm a
TBQueue TVar stm Natural
rsize TVar stm [a]
readT TVar stm Natural
wsize TVar stm [a]
writeT Natural
size)
writeTBQueue :: MonadSTM stm => TBQueue stm a -> a -> stm ()
writeTBQueue :: TBQueue stm a -> a -> stm ()
writeTBQueue (TBQueue TVar stm Natural
rsize TVar stm [a]
_ TVar stm Natural
wsize TVar stm [a]
writeT Natural
_) a
a = do
Natural
w <- TVar stm Natural -> stm Natural
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
wsize
if Natural
w Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
0
then TVar stm Natural -> Natural -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm Natural
wsize (Natural -> stm ()) -> Natural -> stm ()
forall a b. (a -> b) -> a -> b
$! Natural
w Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1
else do
Natural
r <- TVar stm Natural -> stm Natural
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
rsize
if Natural
r Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
0
then do
TVar stm Natural -> Natural -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm Natural
rsize Natural
0
TVar stm Natural -> Natural -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm Natural
wsize (Natural -> stm ()) -> Natural -> stm ()
forall a b. (a -> b) -> a -> b
$! Natural
r Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1
else stm ()
forall (stm :: * -> *) a. MonadSTM stm => stm a
retry
[a]
listend <- TVar stm [a] -> stm [a]
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
writeT
TVar stm [a] -> [a] -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
writeT (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
listend)
readTBQueue :: MonadSTM stm => TBQueue stm a -> stm a
readTBQueue :: TBQueue stm a -> stm a
readTBQueue (TBQueue TVar stm Natural
rsize TVar stm [a]
readT TVar stm Natural
_ TVar stm [a]
writeT Natural
_) = do
[a]
xs <- TVar stm [a] -> stm [a]
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
readT
Natural
r <- TVar stm Natural -> stm Natural
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
rsize
TVar stm Natural -> Natural -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm Natural
rsize (Natural -> stm ()) -> Natural -> stm ()
forall a b. (a -> b) -> a -> b
$! Natural
r Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1
case [a]
xs of
(a
x:[a]
xs') -> do
TVar stm [a] -> [a] -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
readT [a]
xs'
a -> stm a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
[] -> do
[a]
ys <- TVar stm [a] -> stm [a]
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
writeT
case [a]
ys of
[] -> stm a
forall (stm :: * -> *) a. MonadSTM stm => stm a
retry
[a]
_ -> do
let (a
z:[a]
zs) = [a] -> [a]
forall a. [a] -> [a]
reverse [a]
ys
TVar stm [a] -> [a] -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
writeT []
TVar stm [a] -> [a] -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
readT [a]
zs
a -> stm a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
z
tryReadTBQueue :: MonadSTM stm => TBQueue stm a -> stm (Maybe a)
tryReadTBQueue :: TBQueue stm a -> stm (Maybe a)
tryReadTBQueue TBQueue stm a
c = (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> stm a -> stm (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TBQueue stm a -> stm a
forall (stm :: * -> *) a. MonadSTM stm => TBQueue stm a -> stm a
readTBQueue TBQueue stm a
c) stm (Maybe a) -> stm (Maybe a) -> stm (Maybe a)
forall (stm :: * -> *) a. MonadSTM stm => stm a -> stm a -> stm a
`orElse` Maybe a -> stm (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
flushTBQueue :: MonadSTM stm => TBQueue stm a -> stm [a]
flushTBQueue :: TBQueue stm a -> stm [a]
flushTBQueue (TBQueue TVar stm Natural
rsize TVar stm [a]
r TVar stm Natural
wsize TVar stm [a]
w Natural
size) = do
[a]
xs <- TVar stm [a] -> stm [a]
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
r
[a]
ys <- TVar stm [a] -> stm [a]
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
w
if [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs Bool -> Bool -> Bool
&& [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
ys
then [a] -> stm [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
else do
TVar stm [a] -> [a] -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
r []
TVar stm [a] -> [a] -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
w []
TVar stm Natural -> Natural -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm Natural
rsize Natural
0
TVar stm Natural -> Natural -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm Natural
wsize Natural
size
[a] -> stm [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a]
forall a. [a] -> [a]
reverse [a]
ys)
peekTBQueue :: MonadSTM stm => TBQueue stm a -> stm a
peekTBQueue :: TBQueue stm a -> stm a
peekTBQueue (TBQueue TVar stm Natural
_ TVar stm [a]
readT TVar stm Natural
_ TVar stm [a]
writeT Natural
_) = do
[a]
xs <- TVar stm [a] -> stm [a]
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
readT
case [a]
xs of
(a
x:[a]
_) -> a -> stm a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
[] -> do
[a]
ys <- TVar stm [a] -> stm [a]
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
writeT
case [a]
ys of
[] -> stm a
forall (stm :: * -> *) a. MonadSTM stm => stm a
retry
[a]
_ -> do
let (a
z:[a]
zs) = [a] -> [a]
forall a. [a] -> [a]
reverse [a]
ys
TVar stm [a] -> [a] -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
writeT []
TVar stm [a] -> [a] -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
readT (a
za -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
zs)
a -> stm a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
z
tryPeekTBQueue :: MonadSTM stm => TBQueue stm a -> stm (Maybe a)
tryPeekTBQueue :: TBQueue stm a -> stm (Maybe a)
tryPeekTBQueue TBQueue stm a
c = do
Maybe a
m <- TBQueue stm a -> stm (Maybe a)
forall (stm :: * -> *) a.
MonadSTM stm =>
TBQueue stm a -> stm (Maybe a)
tryReadTBQueue TBQueue stm a
c
case Maybe a
m of
Maybe a
Nothing -> Maybe a -> stm (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
Just a
x -> do
TBQueue stm a -> a -> stm ()
forall (stm :: * -> *) a.
MonadSTM stm =>
TBQueue stm a -> a -> stm ()
unGetTBQueue TBQueue stm a
c a
x
Maybe a -> stm (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
m
unGetTBQueue :: MonadSTM stm => TBQueue stm a -> a -> stm ()
unGetTBQueue :: TBQueue stm a -> a -> stm ()
unGetTBQueue (TBQueue TVar stm Natural
rsize TVar stm [a]
readT TVar stm Natural
wsize TVar stm [a]
_ Natural
_) a
a = do
Natural
r <- TVar stm Natural -> stm Natural
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
rsize
if Natural
r Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
0
then TVar stm Natural -> Natural -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm Natural
rsize (Natural -> stm ()) -> Natural -> stm ()
forall a b. (a -> b) -> a -> b
$! Natural
r Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1
else do
Natural
w <- TVar stm Natural -> stm Natural
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
wsize
if Natural
w Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
0
then TVar stm Natural -> Natural -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm Natural
wsize (Natural -> stm ()) -> Natural -> stm ()
forall a b. (a -> b) -> a -> b
$! Natural
w Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
1
else stm ()
forall (stm :: * -> *) a. MonadSTM stm => stm a
retry
[a]
xs <- TVar stm [a] -> stm [a]
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
readT
TVar stm [a] -> [a] -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
readT (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)
lengthTBQueue :: MonadSTM stm => TBQueue stm a -> stm Natural
lengthTBQueue :: TBQueue stm a -> stm Natural
lengthTBQueue (TBQueue TVar stm Natural
rsize TVar stm [a]
_ TVar stm Natural
wsize TVar stm [a]
_ Natural
size) = do
Natural
r <- TVar stm Natural -> stm Natural
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
rsize
Natural
w <- TVar stm Natural -> stm Natural
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
wsize
Natural -> stm Natural
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Natural -> stm Natural) -> Natural -> stm Natural
forall a b. (a -> b) -> a -> b
$! Natural
size Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
r Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
w
isEmptyTBQueue :: MonadSTM stm => TBQueue stm a -> stm Bool
isEmptyTBQueue :: TBQueue stm a -> stm Bool
isEmptyTBQueue (TBQueue TVar stm Natural
_ TVar stm [a]
readT TVar stm Natural
_ TVar stm [a]
writeT Natural
_) = do
[a]
xs <- TVar stm [a] -> stm [a]
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
readT
case [a]
xs of
(a
_:[a]
_) -> Bool -> stm Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
[] -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([a] -> Bool) -> stm [a] -> stm Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar stm [a] -> stm [a]
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm [a]
writeT
isFullTBQueue :: MonadSTM stm => TBQueue stm a -> stm Bool
isFullTBQueue :: TBQueue stm a -> stm Bool
isFullTBQueue (TBQueue TVar stm Natural
rsize TVar stm [a]
_ TVar stm Natural
wsize TVar stm [a]
_ Natural
_) = do
Natural
w <- TVar stm Natural -> stm Natural
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
wsize
if Natural
w Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
0
then Bool -> stm Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
else (Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
>Natural
0) (Natural -> Bool) -> stm Natural -> stm Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar stm Natural -> stm Natural
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> stm a
readTVar TVar stm Natural
rsize