{-# 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 -- Copyright : (c) The University of Glasgow 2012 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : non-portable (requires STM) -- -- A 'TQueue' is like a 'TChan', with two important differences: -- -- * it has faster throughput than both 'TChan' and 'Chan' (although -- the costs are amortised, so the cost of individual operations -- can vary a lot). -- -- * it does /not/ provide equivalents of the 'dupTChan' and -- 'cloneTChan' operations. -- -- The implementation is based on the traditional purely-functional -- queue representation that uses two lists to obtain amortised /O(1)/ -- enqueue and dequeue operations. -- -- @since 2.4 ----------------------------------------------------------------------------- module Control.Concurrent.STM.TQueue ( -- * TQueue TQueue, newTQueue, newTQueueIO, readTQueue, tryReadTQueue, flushTQueue, peekTQueue, tryPeekTQueue, writeTQueue, unGetTQueue, isEmptyTQueue, ) where import GHC.Conc import Control.Monad (unless) import Data.Typeable (Typeable) -- | 'TQueue' is an abstract type representing an unbounded FIFO channel. -- -- @since 2.4 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 -- |Build and returns a new instance of 'TQueue' 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) -- |@IO@ version of 'newTQueue'. This is useful for creating top-level -- 'TQueue's using 'System.IO.Unsafe.unsafePerformIO', because using -- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't -- possible. 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) -- |Write a value to a 'TQueue'. 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) -- |Read the next value from the 'TQueue'. 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 -- NB. lazy: we want the transaction to be -- short, otherwise it will conflict 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 -- | A version of 'readTQueue' which does not retry. Instead it -- returns @Nothing@ if no value is available. 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 -- | Efficiently read the entire contents of a 'TQueue' into a list. This -- function never retries. -- -- @since 2.4.5 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) -- | Get the next value from the @TQueue@ without removing it, -- retrying if the channel is empty. 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 -- NB. lazy: we want the transaction to be -- short, otherwise it will conflict 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 -- | A version of 'peekTQueue' which does not retry. Instead it -- returns @Nothing@ if no value is available. 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 -- |Put a data item back onto a channel, where it will be the next item read. 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) -- |Returns 'True' if the supplied 'TQueue' is empty. 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