module Control.Concurrent.Classy.STM.TQueue
(
TQueue
, newTQueue
, readTQueue
, tryReadTQueue
, flushTQueue
, peekTQueue
, tryPeekTQueue
, writeTQueue
, unGetTQueue
, isEmptyTQueue
) where
import Control.Monad (unless)
import Control.Monad.STM.Class
data TQueue stm a = TQueue (TVar stm [a])
(TVar stm [a])
newTQueue :: MonadSTM stm => stm (TQueue stm a)
newTQueue :: stm (TQueue stm a)
newTQueue = 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 []
TQueue stm a -> stm (TQueue stm a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TVar stm [a] -> TVar stm [a] -> TQueue stm a
forall (stm :: * -> *) a.
TVar stm [a] -> TVar stm [a] -> TQueue stm a
TQueue TVar stm [a]
readT TVar stm [a]
writeT)
writeTQueue :: MonadSTM stm => TQueue stm a -> a -> stm ()
writeTQueue :: TQueue stm a -> a -> stm ()
writeTQueue (TQueue TVar stm [a]
_ TVar stm [a]
writeT) a
a = do
[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)
readTQueue :: MonadSTM stm => TQueue stm a -> stm a
readTQueue :: TQueue stm a -> stm a
readTQueue (TQueue TVar stm [a]
readT TVar stm [a]
writeT) = 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]
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
tryReadTQueue :: MonadSTM stm => TQueue stm a -> stm (Maybe a)
tryReadTQueue :: TQueue stm a -> stm (Maybe a)
tryReadTQueue TQueue 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
<$> TQueue stm a -> stm a
forall (stm :: * -> *) a. MonadSTM stm => TQueue stm a -> stm a
readTQueue TQueue 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
flushTQueue :: MonadSTM stm => TQueue stm a -> stm [a]
flushTQueue :: TQueue stm a -> stm [a]
flushTQueue (TQueue TVar stm [a]
r TVar stm [a]
w) = 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
Bool -> stm () -> stm ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs) (stm () -> stm ()) -> stm () -> stm ()
forall a b. (a -> b) -> a -> b
$ TVar stm [a] -> [a] -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
r []
Bool -> stm () -> stm ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
ys) (stm () -> stm ()) -> stm () -> stm ()
forall a b. (a -> b) -> a -> b
$ TVar stm [a] -> [a] -> stm ()
forall (stm :: * -> *) a. MonadSTM stm => TVar stm a -> a -> stm ()
writeTVar TVar stm [a]
w []
[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)
peekTQueue :: MonadSTM stm => TQueue stm a -> stm a
peekTQueue :: TQueue stm a -> stm a
peekTQueue (TQueue TVar stm [a]
readT TVar stm [a]
writeT) = 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
tryPeekTQueue :: MonadSTM stm => TQueue stm a -> stm (Maybe a)
tryPeekTQueue :: TQueue stm a -> stm (Maybe a)
tryPeekTQueue TQueue stm a
c = do
Maybe a
m <- TQueue stm a -> stm (Maybe a)
forall (stm :: * -> *) a.
MonadSTM stm =>
TQueue stm a -> stm (Maybe a)
tryReadTQueue TQueue 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
TQueue stm a -> a -> stm ()
forall (stm :: * -> *) a.
MonadSTM stm =>
TQueue stm a -> a -> stm ()
unGetTQueue TQueue stm a
c a
x
Maybe a -> stm (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
m
unGetTQueue :: MonadSTM stm => TQueue stm a -> a -> stm ()
unGetTQueue :: TQueue stm a -> a -> stm ()
unGetTQueue (TQueue TVar stm [a]
readT TVar stm [a]
_) a
a = do
[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)
isEmptyTQueue :: MonadSTM stm => TQueue stm a -> stm Bool
isEmptyTQueue :: TQueue stm a -> stm Bool
isEmptyTQueue (TQueue TVar stm [a]
readT TVar stm [a]
writeT) = 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