1{-# OPTIONS_GHC -fno-warn-name-shadowing #-} 2{-# LANGUAGE CPP, DeriveDataTypeable #-} 3 4#if __GLASGOW_HASKELL__ >= 701 5{-# LANGUAGE Trustworthy #-} 6#endif 7 8----------------------------------------------------------------------------- 9-- | 10-- Module : Control.Concurrent.STM.TQueue 11-- Copyright : (c) The University of Glasgow 2012 12-- License : BSD-style (see the file libraries/base/LICENSE) 13-- 14-- Maintainer : libraries@haskell.org 15-- Stability : experimental 16-- Portability : non-portable (requires STM) 17-- 18-- A 'TQueue' is like a 'TChan', with two important differences: 19-- 20-- * it has faster throughput than both 'TChan' and 'Chan' (although 21-- the costs are amortised, so the cost of individual operations 22-- can vary a lot). 23-- 24-- * it does /not/ provide equivalents of the 'dupTChan' and 25-- 'cloneTChan' operations. 26-- 27-- The implementation is based on the traditional purely-functional 28-- queue representation that uses two lists to obtain amortised /O(1)/ 29-- enqueue and dequeue operations. 30-- 31-- @since 2.4 32----------------------------------------------------------------------------- 33 34module Control.Concurrent.STM.TQueue ( 35 -- * TQueue 36 TQueue, 37 newTQueue, 38 newTQueueIO, 39 readTQueue, 40 tryReadTQueue, 41 flushTQueue, 42 peekTQueue, 43 tryPeekTQueue, 44 writeTQueue, 45 unGetTQueue, 46 isEmptyTQueue, 47 ) where 48 49import GHC.Conc 50import Control.Monad (unless) 51import Data.Typeable (Typeable) 52 53-- | 'TQueue' is an abstract type representing an unbounded FIFO channel. 54-- 55-- @since 2.4 56data TQueue a = TQueue {-# UNPACK #-} !(TVar [a]) 57 {-# UNPACK #-} !(TVar [a]) 58 deriving Typeable 59 60instance Eq (TQueue a) where 61 TQueue a _ == TQueue b _ = a == b 62 63-- |Build and returns a new instance of 'TQueue' 64newTQueue :: STM (TQueue a) 65newTQueue = do 66 read <- newTVar [] 67 write <- newTVar [] 68 return (TQueue read write) 69 70-- |@IO@ version of 'newTQueue'. This is useful for creating top-level 71-- 'TQueue's using 'System.IO.Unsafe.unsafePerformIO', because using 72-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't 73-- possible. 74newTQueueIO :: IO (TQueue a) 75newTQueueIO = do 76 read <- newTVarIO [] 77 write <- newTVarIO [] 78 return (TQueue read write) 79 80-- |Write a value to a 'TQueue'. 81writeTQueue :: TQueue a -> a -> STM () 82writeTQueue (TQueue _read write) a = do 83 listend <- readTVar write 84 writeTVar write (a:listend) 85 86-- |Read the next value from the 'TQueue'. 87readTQueue :: TQueue a -> STM a 88readTQueue (TQueue read write) = do 89 xs <- readTVar read 90 case xs of 91 (x:xs') -> do 92 writeTVar read xs' 93 return x 94 [] -> do 95 ys <- readTVar write 96 case ys of 97 [] -> retry 98 _ -> do 99 let (z:zs) = reverse ys -- NB. lazy: we want the transaction to be 100 -- short, otherwise it will conflict 101 writeTVar write [] 102 writeTVar read zs 103 return z 104 105-- | A version of 'readTQueue' which does not retry. Instead it 106-- returns @Nothing@ if no value is available. 107tryReadTQueue :: TQueue a -> STM (Maybe a) 108tryReadTQueue c = fmap Just (readTQueue c) `orElse` return Nothing 109 110-- | Efficiently read the entire contents of a 'TQueue' into a list. This 111-- function never retries. 112-- 113-- @since 2.4.5 114flushTQueue :: TQueue a -> STM [a] 115flushTQueue (TQueue read write) = do 116 xs <- readTVar read 117 ys <- readTVar write 118 unless (null xs) $ writeTVar read [] 119 unless (null ys) $ writeTVar write [] 120 return (xs ++ reverse ys) 121 122-- | Get the next value from the @TQueue@ without removing it, 123-- retrying if the channel is empty. 124peekTQueue :: TQueue a -> STM a 125peekTQueue (TQueue read write) = do 126 xs <- readTVar read 127 case xs of 128 (x:_) -> return x 129 [] -> do 130 ys <- readTVar write 131 case ys of 132 [] -> retry 133 _ -> do 134 let (z:zs) = reverse ys -- NB. lazy: we want the transaction to be 135 -- short, otherwise it will conflict 136 writeTVar write [] 137 writeTVar read (z:zs) 138 return z 139 140-- | A version of 'peekTQueue' which does not retry. Instead it 141-- returns @Nothing@ if no value is available. 142tryPeekTQueue :: TQueue a -> STM (Maybe a) 143tryPeekTQueue c = do 144 m <- tryReadTQueue c 145 case m of 146 Nothing -> return Nothing 147 Just x -> do 148 unGetTQueue c x 149 return m 150 151-- |Put a data item back onto a channel, where it will be the next item read. 152unGetTQueue :: TQueue a -> a -> STM () 153unGetTQueue (TQueue read _write) a = do 154 xs <- readTVar read 155 writeTVar read (a:xs) 156 157-- |Returns 'True' if the supplied 'TQueue' is empty. 158isEmptyTQueue :: TQueue a -> STM Bool 159isEmptyTQueue (TQueue read write) = do 160 xs <- readTVar read 161 case xs of 162 (_:_) -> return False 163 [] -> do ys <- readTVar write 164 case ys of 165 [] -> return True 166 _ -> return False 167