{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Concurrent.STM.TBQueue -- 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) -- -- 'TBQueue' is a bounded version of 'TQueue'. The queue has a maximum -- capacity set when it is created. If the queue already contains the -- maximum number of elements, then 'writeTBQueue' blocks until an -- element is removed from the queue. -- -- 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.TBQueue ( -- * TBQueue TBQueue, newTBQueue, newTBQueueIO, readTBQueue, tryReadTBQueue, flushTBQueue, peekTBQueue, tryPeekTBQueue, writeTBQueue, unGetTBQueue, lengthTBQueue, isEmptyTBQueue, isFullTBQueue, ) where import Control.Monad (unless) import Data.Typeable (Typeable) import GHC.Conc (STM, TVar, newTVar, newTVarIO, orElse, readTVar, retry, writeTVar) import Numeric.Natural (Natural) import Prelude hiding (read) -- | 'TBQueue' is an abstract type representing a bounded FIFO channel. -- -- @since 2.4 data TBQueue a = TBQueue {-# UNPACK #-} !(TVar Natural) -- CR: read capacity {-# UNPACK #-} !(TVar [a]) -- R: elements waiting to be read {-# UNPACK #-} !(TVar Natural) -- CW: write capacity {-# UNPACK #-} !(TVar [a]) -- W: elements written (head is most recent) !(Natural) -- CAP: initial capacity deriving Typeable instance Eq (TBQueue a) where TBQueue TVar Natural a TVar [a] _ TVar Natural _ TVar [a] _ Natural _ == :: TBQueue a -> TBQueue a -> Bool == TBQueue TVar Natural b TVar [a] _ TVar Natural _ TVar [a] _ Natural _ = TVar Natural a TVar Natural -> TVar Natural -> Bool forall a. Eq a => a -> a -> Bool == TVar Natural b -- Total channel capacity remaining is CR + CW. Reads only need to -- access CR, writes usually need to access only CW but sometimes need -- CR. So in the common case we avoid contention between CR and CW. -- -- - when removing an element from R: -- CR := CR + 1 -- -- - when adding an element to W: -- if CW is non-zero -- then CW := CW - 1 -- then if CR is non-zero -- then CW := CR - 1; CR := 0 -- else **FULL** -- | Builds and returns a new instance of 'TBQueue'. newTBQueue :: Natural -- ^ maximum number of elements the queue can hold -> STM (TBQueue a) newTBQueue :: forall a. Natural -> STM (TBQueue a) newTBQueue Natural size = 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 [] TVar Natural rsize <- Natural -> STM (TVar Natural) forall a. a -> STM (TVar a) newTVar Natural 0 TVar Natural wsize <- Natural -> STM (TVar Natural) forall a. a -> STM (TVar a) newTVar Natural size TBQueue a -> STM (TBQueue a) forall a. a -> STM a forall (m :: * -> *) a. Monad m => a -> m a return (TVar Natural -> TVar [a] -> TVar Natural -> TVar [a] -> Natural -> TBQueue a forall a. TVar Natural -> TVar [a] -> TVar Natural -> TVar [a] -> Natural -> TBQueue a TBQueue TVar Natural rsize TVar [a] read TVar Natural wsize TVar [a] write Natural size) -- |@IO@ version of 'newTBQueue'. This is useful for creating top-level -- 'TBQueue's using 'System.IO.Unsafe.unsafePerformIO', because using -- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't -- possible. newTBQueueIO :: Natural -> IO (TBQueue a) newTBQueueIO :: forall a. Natural -> IO (TBQueue a) newTBQueueIO Natural size = 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 [] TVar Natural rsize <- Natural -> IO (TVar Natural) forall a. a -> IO (TVar a) newTVarIO Natural 0 TVar Natural wsize <- Natural -> IO (TVar Natural) forall a. a -> IO (TVar a) newTVarIO Natural size TBQueue a -> IO (TBQueue a) forall a. a -> IO a forall (m :: * -> *) a. Monad m => a -> m a return (TVar Natural -> TVar [a] -> TVar Natural -> TVar [a] -> Natural -> TBQueue a forall a. TVar Natural -> TVar [a] -> TVar Natural -> TVar [a] -> Natural -> TBQueue a TBQueue TVar Natural rsize TVar [a] read TVar Natural wsize TVar [a] write Natural size) -- |Write a value to a 'TBQueue'; blocks if the queue is full. writeTBQueue :: TBQueue a -> a -> STM () writeTBQueue :: forall a. TBQueue a -> a -> STM () writeTBQueue (TBQueue TVar Natural rsize TVar [a] _read TVar Natural wsize TVar [a] write Natural _size) a a = do Natural w <- TVar Natural -> STM Natural forall a. TVar a -> STM a readTVar TVar Natural wsize if (Natural w Natural -> Natural -> Bool forall a. Ord a => a -> a -> Bool > Natural 0) then do TVar Natural -> Natural -> STM () forall a. TVar a -> a -> STM () writeTVar TVar Natural wsize (Natural -> STM ()) -> Natural -> STM () forall a b. (a -> b) -> a -> b $! Natural w Natural -> Natural -> Natural forall a. Num a => a -> a -> a - Natural 1 else do Natural r <- TVar Natural -> STM Natural forall a. TVar a -> STM a readTVar TVar Natural rsize if (Natural r Natural -> Natural -> Bool forall a. Ord a => a -> a -> Bool > Natural 0) then do TVar Natural -> Natural -> STM () forall a. TVar a -> a -> STM () writeTVar TVar Natural rsize Natural 0 TVar Natural -> Natural -> STM () forall a. TVar a -> a -> STM () writeTVar TVar Natural wsize (Natural -> STM ()) -> Natural -> STM () forall a b. (a -> b) -> a -> b $! Natural r Natural -> Natural -> Natural forall a. Num a => a -> a -> a - Natural 1 else STM () forall a. STM a retry [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 'TBQueue'. readTBQueue :: TBQueue a -> STM a readTBQueue :: forall a. TBQueue a -> STM a readTBQueue (TBQueue TVar Natural rsize TVar [a] read TVar Natural _wsize TVar [a] write Natural _size) = do [a] xs <- TVar [a] -> STM [a] forall a. TVar a -> STM a readTVar TVar [a] read Natural r <- TVar Natural -> STM Natural forall a. TVar a -> STM a readTVar TVar Natural rsize TVar Natural -> Natural -> STM () forall a. TVar a -> a -> STM () writeTVar TVar Natural rsize (Natural -> STM ()) -> Natural -> STM () forall a b. (a -> b) -> a -> b $! Natural r Natural -> Natural -> Natural forall a. Num a => a -> a -> a + Natural 1 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 -- NB. lazy: we want the transaction to be -- short, otherwise it will conflict let ~(a z,[a] zs) = case [a] -> [a] forall a. [a] -> [a] reverse [a] ys of a z':[a] zs' -> (a z',[a] zs') [a] _ -> [Char] -> (a, [a]) forall a. HasCallStack => [Char] -> a error [Char] "readTBQueue: impossible" 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 'readTBQueue' which does not retry. Instead it -- returns @Nothing@ if no value is available. tryReadTBQueue :: TBQueue a -> STM (Maybe a) tryReadTBQueue :: forall a. TBQueue a -> STM (Maybe a) tryReadTBQueue TBQueue 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 (TBQueue a -> STM a forall a. TBQueue a -> STM a readTBQueue TBQueue 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 'TBQueue' into a list. This -- function never retries. -- -- @since 2.4.5 flushTBQueue :: TBQueue a -> STM [a] flushTBQueue :: forall a. TBQueue a -> STM [a] flushTBQueue (TBQueue TVar Natural rsize TVar [a] read TVar Natural wsize TVar [a] write Natural size) = 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 if [a] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [a] xs Bool -> Bool -> Bool && [a] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [a] ys then [a] -> STM [a] forall a. a -> STM a forall (m :: * -> *) a. Monad m => a -> m a return [] else do 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 [] TVar Natural -> Natural -> STM () forall a. TVar a -> a -> STM () writeTVar TVar Natural rsize Natural 0 TVar Natural -> Natural -> STM () forall a. TVar a -> a -> STM () writeTVar TVar Natural wsize Natural size [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 @TBQueue@ without removing it, -- retrying if the channel is empty. peekTBQueue :: TBQueue a -> STM a peekTBQueue :: forall a. TBQueue a -> STM a peekTBQueue (TBQueue TVar Natural _ TVar [a] read TVar Natural _ TVar [a] write Natural _) = 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 'peekTBQueue' which does not retry. Instead it -- returns @Nothing@ if no value is available. tryPeekTBQueue :: TBQueue a -> STM (Maybe a) tryPeekTBQueue :: forall a. TBQueue a -> STM (Maybe a) tryPeekTBQueue TBQueue a c = do Maybe a m <- TBQueue a -> STM (Maybe a) forall a. TBQueue a -> STM (Maybe a) tryReadTBQueue TBQueue 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 TBQueue a -> a -> STM () forall a. TBQueue a -> a -> STM () unGetTBQueue TBQueue 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. -- Blocks if the queue is full. unGetTBQueue :: TBQueue a -> a -> STM () unGetTBQueue :: forall a. TBQueue a -> a -> STM () unGetTBQueue (TBQueue TVar Natural rsize TVar [a] read TVar Natural wsize TVar [a] _write Natural _size) a a = do Natural r <- TVar Natural -> STM Natural forall a. TVar a -> STM a readTVar TVar Natural rsize if (Natural r Natural -> Natural -> Bool forall a. Ord a => a -> a -> Bool > Natural 0) then do TVar Natural -> Natural -> STM () forall a. TVar a -> a -> STM () writeTVar TVar Natural rsize (Natural -> STM ()) -> Natural -> STM () forall a b. (a -> b) -> a -> b $! Natural r Natural -> Natural -> Natural forall a. Num a => a -> a -> a - Natural 1 else do Natural w <- TVar Natural -> STM Natural forall a. TVar a -> STM a readTVar TVar Natural wsize if (Natural w Natural -> Natural -> Bool forall a. Ord a => a -> a -> Bool > Natural 0) then TVar Natural -> Natural -> STM () forall a. TVar a -> a -> STM () writeTVar TVar Natural wsize (Natural -> STM ()) -> Natural -> STM () forall a b. (a -> b) -> a -> b $! Natural w Natural -> Natural -> Natural forall a. Num a => a -> a -> a - Natural 1 else STM () forall a. STM a retry [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) -- |Return the length of a 'TBQueue'. -- -- @since 2.5.0.0 lengthTBQueue :: TBQueue a -> STM Natural lengthTBQueue :: forall a. TBQueue a -> STM Natural lengthTBQueue (TBQueue TVar Natural rsize TVar [a] _read TVar Natural wsize TVar [a] _write Natural size) = do Natural r <- TVar Natural -> STM Natural forall a. TVar a -> STM a readTVar TVar Natural rsize Natural w <- TVar Natural -> STM Natural forall a. TVar a -> STM a readTVar TVar Natural wsize Natural -> STM Natural forall a. a -> STM a forall (m :: * -> *) a. Monad m => a -> m a return (Natural -> STM Natural) -> Natural -> STM Natural forall a b. (a -> b) -> a -> b $! Natural size Natural -> Natural -> Natural forall a. Num a => a -> a -> a - Natural r Natural -> Natural -> Natural forall a. Num a => a -> a -> a - Natural w -- |Returns 'True' if the supplied 'TBQueue' is empty. isEmptyTBQueue :: TBQueue a -> STM Bool isEmptyTBQueue :: forall a. TBQueue a -> STM Bool isEmptyTBQueue (TBQueue TVar Natural _rsize TVar [a] read TVar Natural _wsize TVar [a] write Natural _size) = 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 -- |Returns 'True' if the supplied 'TBQueue' is full. -- -- @since 2.4.3 isFullTBQueue :: TBQueue a -> STM Bool isFullTBQueue :: forall a. TBQueue a -> STM Bool isFullTBQueue (TBQueue TVar Natural rsize TVar [a] _read TVar Natural wsize TVar [a] _write Natural _size) = do Natural w <- TVar Natural -> STM Natural forall a. TVar a -> STM a readTVar TVar Natural wsize if (Natural w Natural -> Natural -> Bool forall a. Ord a => a -> a -> Bool > Natural 0) then Bool -> STM Bool forall a. a -> STM a forall (m :: * -> *) a. Monad m => a -> m a return Bool False else do Natural r <- TVar Natural -> STM Natural forall a. TVar a -> STM a readTVar TVar Natural rsize if (Natural r Natural -> Natural -> Bool forall a. Ord a => a -> a -> Bool > Natural 0) then Bool -> STM Bool forall a. a -> STM a forall (m :: * -> *) a. Monad m => a -> m a return Bool False else Bool -> STM Bool forall a. a -> STM a forall (m :: * -> *) a. Monad m => a -> m a return Bool True