{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
{-# LANGUAGE CPP, DeriveDataTypeable #-}
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif
module Control.Concurrent.STM.TQueue (
TQueue,
newTQueue,
newTQueueIO,
readTQueue,
tryReadTQueue,
flushTQueue,
peekTQueue,
tryPeekTQueue,
writeTQueue,
unGetTQueue,
isEmptyTQueue,
) where
import GHC.Conc
import Control.Monad (unless)
import Data.Typeable (Typeable)
data TQueue a = TQueue {-# UNPACK #-} !(TVar [a])
{-# UNPACK #-} !(TVar [a])
deriving Typeable
instance Eq (TQueue a) where
TQueue TVar [a]
a TVar [a]
_ == :: TQueue a -> TQueue a -> Bool
== TQueue TVar [a]
b TVar [a]
_ = TVar [a]
a forall a. Eq a => a -> a -> Bool
== TVar [a]
b
newTQueue :: STM (TQueue a)
newTQueue :: forall a. STM (TQueue a)
newTQueue = do
TVar [a]
read <- forall a. a -> STM (TVar a)
newTVar []
TVar [a]
write <- forall a. a -> STM (TVar a)
newTVar []
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. TVar [a] -> TVar [a] -> TQueue a
TQueue TVar [a]
read TVar [a]
write)
newTQueueIO :: IO (TQueue a)
newTQueueIO :: forall a. IO (TQueue a)
newTQueueIO = do
TVar [a]
read <- forall a. a -> IO (TVar a)
newTVarIO []
TVar [a]
write <- forall a. a -> IO (TVar a)
newTVarIO []
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. TVar [a] -> TVar [a] -> TQueue a
TQueue TVar [a]
read TVar [a]
write)
writeTQueue :: TQueue a -> a -> STM ()
writeTQueue :: forall a. TQueue a -> a -> STM ()
writeTQueue (TQueue TVar [a]
_read TVar [a]
write) a
a = do
[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)
readTQueue :: TQueue a -> STM a
readTQueue :: forall a. TQueue a -> STM a
readTQueue (TQueue TVar [a]
read TVar [a]
write) = do
[a]
xs <- forall a. TVar a -> STM a
readTVar TVar [a]
read
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) = 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]
zs
forall (m :: * -> *) a. Monad m => a -> m a
return a
z
tryReadTQueue :: TQueue a -> STM (Maybe a)
tryReadTQueue :: forall a. TQueue a -> STM (Maybe a)
tryReadTQueue TQueue a
c = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just (forall a. TQueue a -> STM a
readTQueue TQueue 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
flushTQueue :: TQueue a -> STM [a]
flushTQueue :: forall a. TQueue a -> STM [a]
flushTQueue (TQueue TVar [a]
read TVar [a]
write) = 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs) forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar [a]
read []
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
ys) forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar [a]
write []
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
xs forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
reverse [a]
ys)
peekTQueue :: TQueue a -> STM a
peekTQueue :: forall a. TQueue a -> STM a
peekTQueue (TQueue TVar [a]
read TVar [a]
write) = 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
tryPeekTQueue :: TQueue a -> STM (Maybe a)
tryPeekTQueue :: forall a. TQueue a -> STM (Maybe a)
tryPeekTQueue TQueue a
c = do
Maybe a
m <- forall a. TQueue a -> STM (Maybe a)
tryReadTQueue TQueue 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. TQueue a -> a -> STM ()
unGetTQueue TQueue a
c a
x
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
m
unGetTQueue :: TQueue a -> a -> STM ()
unGetTQueue :: forall a. TQueue a -> a -> STM ()
unGetTQueue (TQueue TVar [a]
read TVar [a]
_write) a
a = do
[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)
isEmptyTQueue :: TQueue a -> STM Bool
isEmptyTQueue :: forall a. TQueue a -> STM Bool
isEmptyTQueue (TQueue TVar [a]
read TVar [a]
write) = 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