{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# 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 a :: TVar [a]
a _ == :: TQueue a -> TQueue a -> Bool
== TQueue b :: TVar [a]
b _ = TVar [a]
a TVar [a] -> TVar [a] -> Bool
forall a. Eq a => a -> a -> Bool
== TVar [a]
b
newTQueue :: STM (TQueue a)
newTQueue :: STM (TQueue a)
newTQueue = do
TVar [a]
read <- [a] -> STM (TVar [a])
forall a. a -> STM (TVar a)
newTVar []
TVar [a]
write <- [a] -> STM (TVar [a])
forall a. a -> STM (TVar a)
newTVar []
TQueue a -> STM (TQueue a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar [a] -> TVar [a] -> TQueue a
forall a. TVar [a] -> TVar [a] -> TQueue a
TQueue TVar [a]
read TVar [a]
write)
newTQueueIO :: IO (TQueue a)
newTQueueIO :: IO (TQueue a)
newTQueueIO = do
TVar [a]
read <- [a] -> IO (TVar [a])
forall a. a -> IO (TVar a)
newTVarIO []
TVar [a]
write <- [a] -> IO (TVar [a])
forall a. a -> IO (TVar a)
newTVarIO []
TQueue a -> IO (TQueue a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar [a] -> TVar [a] -> TQueue a
forall a. TVar [a] -> TVar [a] -> TQueue a
TQueue TVar [a]
read TVar [a]
write)
writeTQueue :: TQueue a -> a -> STM ()
writeTQueue :: TQueue a -> a -> STM ()
writeTQueue (TQueue _read :: TVar [a]
_read write :: TVar [a]
write) a :: a
a = do
[a]
listend <- TVar [a] -> STM [a]
forall a. TVar a -> STM a
readTVar TVar [a]
write
TVar [a] -> [a] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [a]
write (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
listend)
readTQueue :: TQueue a -> STM a
readTQueue :: TQueue a -> STM a
readTQueue (TQueue read :: TVar [a]
read write :: TVar [a]
write) = do
[a]
xs <- TVar [a] -> STM [a]
forall a. TVar a -> STM a
readTVar TVar [a]
read
case [a]
xs of
(x :: a
x:xs' :: [a]
xs') -> do
TVar [a] -> [a] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [a]
read [a]
xs'
a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
[] -> do
[a]
ys <- TVar [a] -> STM [a]
forall a. TVar a -> STM a
readTVar TVar [a]
write
case [a]
ys of
[] -> STM a
forall a. STM a
retry
_ -> do
let (z :: a
z:zs :: [a]
zs) = [a] -> [a]
forall a. [a] -> [a]
reverse [a]
ys
TVar [a] -> [a] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [a]
write []
TVar [a] -> [a] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [a]
read [a]
zs
a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
z
tryReadTQueue :: TQueue a -> STM (Maybe a)
tryReadTQueue :: TQueue a -> STM (Maybe a)
tryReadTQueue c :: TQueue a
c = (a -> Maybe a) -> STM a -> STM (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (TQueue a -> STM a
forall a. TQueue a -> STM a
readTQueue TQueue a
c) STM (Maybe a) -> STM (Maybe a) -> STM (Maybe a)
forall a. STM a -> STM a -> STM a
`orElse` Maybe a -> STM (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
flushTQueue :: TQueue a -> STM [a]
flushTQueue :: TQueue a -> STM [a]
flushTQueue (TQueue read :: TVar [a]
read write :: TVar [a]
write) = do
[a]
xs <- TVar [a] -> STM [a]
forall a. TVar a -> STM a
readTVar TVar [a]
read
[a]
ys <- TVar [a] -> STM [a]
forall a. TVar a -> STM a
readTVar TVar [a]
write
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 [a] -> [a] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [a]
read []
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 [a] -> [a] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [a]
write []
[a] -> STM [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a]
forall a. [a] -> [a]
reverse [a]
ys)
peekTQueue :: TQueue a -> STM a
peekTQueue :: TQueue a -> STM a
peekTQueue c :: TQueue a
c = do
a
x <- TQueue a -> STM a
forall a. TQueue a -> STM a
readTQueue TQueue a
c
TQueue a -> a -> STM ()
forall a. TQueue a -> a -> STM ()
unGetTQueue TQueue a
c a
x
a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
tryPeekTQueue :: TQueue a -> STM (Maybe a)
tryPeekTQueue :: TQueue a -> STM (Maybe a)
tryPeekTQueue c :: TQueue a
c = do
Maybe a
m <- TQueue a -> STM (Maybe a)
forall a. TQueue a -> STM (Maybe a)
tryReadTQueue TQueue a
c
case Maybe a
m of
Nothing -> Maybe a -> STM (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
Just x :: a
x -> do
TQueue a -> a -> STM ()
forall a. TQueue a -> a -> STM ()
unGetTQueue TQueue a
c a
x
Maybe a -> STM (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
m
unGetTQueue :: TQueue a -> a -> STM ()
unGetTQueue :: TQueue a -> a -> STM ()
unGetTQueue (TQueue read :: TVar [a]
read _write :: TVar [a]
_write) a :: a
a = do
[a]
xs <- TVar [a] -> STM [a]
forall a. TVar a -> STM a
readTVar TVar [a]
read
TVar [a] -> [a] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [a]
read (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)
isEmptyTQueue :: TQueue a -> STM Bool
isEmptyTQueue :: TQueue a -> STM Bool
isEmptyTQueue (TQueue read :: TVar [a]
read write :: TVar [a]
write) = do
[a]
xs <- TVar [a] -> STM [a]
forall a. TVar a -> STM a
readTVar TVar [a]
read
case [a]
xs of
(_:_) -> Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
[] -> do [a]
ys <- TVar [a] -> STM [a]
forall a. TVar a -> STM a
readTVar TVar [a]
write
case [a]
ys of
[] -> Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
_ -> Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False