{-# 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 TVar [a] -> TVar [a] -> Bool
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 <- [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 a. a -> STM 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 :: forall a. 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 a. a -> IO 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 :: forall a. TQueue a -> a -> STM ()
writeTQueue (TQueue TVar [a]
_read TVar [a]
write) 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 :: forall a. TQueue a -> STM a
readTQueue (TQueue TVar [a]
read TVar [a]
write) = do
[a]
xs <- TVar [a] -> STM [a]
forall a. TVar a -> STM a
readTVar TVar [a]
read
case [a]
xs of
(a
x:[a]
xs') -> do
TVar [a] -> [a] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [a]
read [a]
xs'
a -> STM a
forall a. 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
[a]
_ -> do
let (a
z:[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 a. a -> STM a
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 = (a -> Maybe a) -> STM a -> STM (Maybe a)
forall a b. (a -> b) -> STM a -> STM b
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 a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
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 <- 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 a. [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 a. [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 a. 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 :: forall a. TQueue a -> STM a
peekTQueue (TQueue TVar [a]
read TVar [a]
write) = do
[a]
xs <- TVar [a] -> STM [a]
forall a. TVar a -> STM a
readTVar TVar [a]
read
case [a]
xs of
(a
x:[a]
_) -> a -> STM a
forall a. 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
[a]
_ -> do
let (a
z:[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
za -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
zs)
a -> STM a
forall a. a -> STM a
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 <- TQueue a -> STM (Maybe a)
forall a. TQueue a -> STM (Maybe a)
tryReadTQueue TQueue a
c
case Maybe a
m of
Maybe a
Nothing -> Maybe a -> STM (Maybe a)
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
Just 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 a. a -> STM a
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 <- 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 :: forall a. TQueue a -> STM Bool
isEmptyTQueue (TQueue TVar [a]
read TVar [a]
write) = do
[a]
xs <- TVar [a] -> STM [a]
forall a. TVar a -> STM a
readTVar TVar [a]
read
case [a]
xs of
(a
_:[a]
_) -> Bool -> STM Bool
forall a. a -> STM a
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 a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
[a]
_ -> Bool -> STM Bool
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False