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