1{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
2{-# LANGUAGE CPP, DeriveDataTypeable #-}
3
4-- HACK: in GHC 7.10, Haddock complains about Control.Monad.STM and
5-- System.IO.Unsafe being imported but unused. However, if we use
6-- CPP to avoid including them under Haddock, then it will fail to
7-- compile!
8#ifdef __HADDOCK__
9{-# OPTIONS_GHC -fno-warn-unused-imports #-}
10#endif
11
12#if __GLASGOW_HASKELL__ >= 701
13#  ifdef __HADDOCK__
14{-# LANGUAGE Trustworthy #-}
15#  else
16{-# LANGUAGE Safe #-}
17#  endif
18#endif
19----------------------------------------------------------------
20--                                                    2015.03.29
21-- |
22-- Module      :  Control.Concurrent.STM.TBMQueue
23-- Copyright   :  Copyright (c) 2011--2015 wren gayle romano
24-- License     :  BSD
25-- Maintainer  :  wren@community.haskell.org
26-- Stability   :  provisional
27-- Portability :  non-portable (GHC STM, DeriveDataTypeable)
28--
29-- A version of "Control.Concurrent.STM.TQueue" where the queue is
30-- bounded in length and closeable. This combines the abilities of
31-- "Control.Concurrent.STM.TBQueue" and "Control.Concurrent.STM.TMQueue".
32--
33-- /Since: 2.0.0/
34----------------------------------------------------------------
35module Control.Concurrent.STM.TBMQueue
36    (
37    -- * The TBMQueue type
38      TBMQueue()
39    -- ** Creating TBMQueues
40    , newTBMQueue
41    , newTBMQueueIO
42    -- ** Reading from TBMQueues
43    , readTBMQueue
44    , tryReadTBMQueue
45    , peekTBMQueue
46    , tryPeekTBMQueue
47    -- ** Writing to TBMQueues
48    , writeTBMQueue
49    , tryWriteTBMQueue
50    , unGetTBMQueue
51    -- ** Closing TBMQueues
52    , closeTBMQueue
53    -- ** Predicates
54    , isClosedTBMQueue
55    , isEmptyTBMQueue
56    , isFullTBMQueue
57    -- ** Other functionality
58    , estimateFreeSlotsTBMQueue
59    , freeSlotsTBMQueue
60    ) where
61
62import Prelude             hiding (reads)
63import Data.Typeable       (Typeable)
64#if __GLASGOW_HASKELL__ < 710
65import Control.Applicative ((<$>))
66#endif
67import Control.Monad.STM   (STM, retry)
68import Control.Concurrent.STM.TVar
69import Control.Concurrent.STM.TQueue -- N.B., GHC only
70
71-- N.B., we need a Custom cabal build-type for this to work.
72#ifdef __HADDOCK__
73import Control.Monad.STM   (atomically)
74import System.IO.Unsafe    (unsafePerformIO)
75#endif
76----------------------------------------------------------------
77
78-- | @TBMQueue@ is an abstract type representing a bounded closeable
79-- FIFO queue.
80data TBMQueue a = TBMQueue
81    {-# UNPACK #-} !(TVar Bool)
82    {-# UNPACK #-} !(TVar Int)
83    {-# UNPACK #-} !(TVar Int)
84    {-# UNPACK #-} !(TQueue a)
85    deriving (Typeable)
86-- The components are:
87-- * Whether the queue has been closed.
88-- * How many free slots we /know/ we have available.
89-- * How many slots have been freed up by successful reads since
90--   the last time the slot count was synchronized by 'isFullTBQueue'.
91-- * The underlying TQueue.
92
93
94-- | Build and returns a new instance of @TBMQueue@ with the given
95-- capacity. /N.B./, we do not verify the capacity is positive, but
96-- if it is non-positive then 'writeTBMQueue' will always retry and
97-- 'isFullTBMQueue' will always be true.
98newTBMQueue :: Int -> STM (TBMQueue a)
99newTBMQueue n = do
100    closed <- newTVar False
101    slots  <- newTVar n
102    reads  <- newTVar 0
103    queue  <- newTQueue
104    return (TBMQueue closed slots reads queue)
105
106
107-- | @IO@ version of 'newTBMQueue'. This is useful for creating
108-- top-level @TBMQueue@s using 'unsafePerformIO', because using
109-- 'atomically' inside 'unsafePerformIO' isn't possible.
110newTBMQueueIO :: Int -> IO (TBMQueue a)
111newTBMQueueIO n = do
112    closed <- newTVarIO False
113    slots  <- newTVarIO n
114    reads  <- newTVarIO 0
115    queue  <- newTQueueIO
116    return (TBMQueue closed slots reads queue)
117
118
119-- | Read the next value from the @TBMQueue@, retrying if the queue
120-- is empty (and not closed). We return @Nothing@ immediately if
121-- the queue is closed and empty.
122readTBMQueue :: TBMQueue a -> STM (Maybe a)
123readTBMQueue (TBMQueue closed _slots reads queue) = do
124    b <- readTVar closed
125    if b
126        then do
127            mx <- tryReadTQueue queue
128            case mx of
129                Nothing -> return mx
130                Just _x -> do
131                    modifyTVar' reads (1 +)
132                    return mx
133        else do
134            x <- readTQueue queue
135            modifyTVar' reads (1 +)
136            return (Just x)
137{-
138-- The above is slightly optimized over the clearer:
139readTBMQueue (TBMQueue closed _slots reads queue) =
140    b  <- readTVar closed
141    b' <- isEmptyTQueue queue
142    if b && b'
143        then return Nothing
144        else do
145            x <- readTQueue queue
146            modifyTVar' reads (1 +)
147            return (Just x)
148-- TODO: compare Core and benchmarks; is the loss of clarity worth it?
149-}
150
151
152-- | A version of 'readTBMQueue' which does not retry. Instead it
153-- returns @Just Nothing@ if the queue is open but no value is
154-- available; it still returns @Nothing@ if the queue is closed
155-- and empty.
156tryReadTBMQueue :: TBMQueue a -> STM (Maybe (Maybe a))
157tryReadTBMQueue (TBMQueue closed _slots reads queue) = do
158    b <- readTVar closed
159    if b
160        then do
161            mx <- tryReadTQueue queue
162            case mx of
163                Nothing -> return Nothing
164                Just _x -> do
165                    modifyTVar' reads (1 +)
166                    return (Just mx)
167        else do
168            mx <- tryReadTQueue queue
169            case mx of
170                Nothing -> return (Just mx)
171                Just _x -> do
172                    modifyTVar' reads (1 +)
173                    return (Just mx)
174{-
175-- The above is slightly optimized over the clearer:
176tryReadTBMQueue (TBMQueue closed _slots reads queue) =
177    b  <- readTVar closed
178    b' <- isEmptyTQueue queue
179    if b && b'
180        then return Nothing
181        else do
182            mx <- tryReadTBMQueue queue
183            case mx of
184                Nothing -> return (Just mx)
185                Just _x -> do
186                    modifyTVar' reads (1 +)
187                    return (Just mx)
188-- TODO: compare Core and benchmarks; is the loss of clarity worth it?
189-}
190
191
192-- | Get the next value from the @TBMQueue@ without removing it,
193-- retrying if the queue is empty.
194peekTBMQueue :: TBMQueue a -> STM (Maybe a)
195peekTBMQueue (TBMQueue closed _slots _reads queue) = do
196    b <- readTVar closed
197    if b
198        then do
199            b' <- isEmptyTQueue queue
200            if b'
201                then return Nothing
202                else Just <$> peekTQueue queue
203        else Just <$> peekTQueue queue
204{-
205-- The above is lazier reading from @queue@ than the clearer:
206peekTBMQueue (TBMQueue closed _slots _reads queue) = do
207    b  <- isEmptyTQueue queue
208    b' <- readTVar closed
209    if b && b'
210        then return Nothing
211        else Just <$> peekTQueue queue
212-- TODO: compare Core and benchmarks; is the loss of clarity worth it?
213-}
214
215
216-- | A version of 'peekTBMQueue' which does not retry. Instead it
217-- returns @Just Nothing@ if the queue is open but no value is
218-- available; it still returns @Nothing@ if the queue is closed
219-- and empty.
220tryPeekTBMQueue :: TBMQueue a -> STM (Maybe (Maybe a))
221tryPeekTBMQueue (TBMQueue closed _slots _reads queue) = do
222    b <- readTVar closed
223    if b
224        then fmap Just <$> tryPeekTQueue queue
225        else Just <$> tryPeekTQueue queue
226{-
227-- The above is lazier reading from @queue@ (and removes an extraneous isEmptyTQueue when using the compatibility layer) than the clearer:
228tryPeekTBMQueue (TBMQueue closed _slots _reads queue) = do
229    b  <- isEmptyTQueue queue
230    b' <- readTVar closed
231    if b && b'
232        then return Nothing
233        else Just <$> tryPeekTQueue queue
234-- TODO: compare Core and benchmarks; is the loss of clarity worth it?
235-}
236
237
238-- | Write a value to a @TBMQueue@, retrying if the queue is full.
239-- If the queue is closed then the value is silently discarded.
240-- Use 'isClosedTBMQueue' to determine if the queue is closed
241-- before writing, as needed.
242writeTBMQueue :: TBMQueue a -> a -> STM ()
243writeTBMQueue self@(TBMQueue closed slots _reads queue) x = do
244    b <- readTVar closed
245    if b
246        then return () -- Discard silently
247        else do
248            n <- estimateFreeSlotsTBMQueue self
249            if n <= 0
250                then retry
251                else do
252                    writeTVar slots $! n - 1
253                    writeTQueue queue x
254
255
256-- | A version of 'writeTBMQueue' which does not retry. Returns @Just
257-- True@ if the value was successfully written, @Just False@ if it
258-- could not be written (but the queue was open), and @Nothing@
259-- if it was discarded (i.e., the queue was closed).
260tryWriteTBMQueue :: TBMQueue a -> a -> STM (Maybe Bool)
261tryWriteTBMQueue self@(TBMQueue closed slots _reads queue) x = do
262    b <- readTVar closed
263    if b
264        then return Nothing
265        else do
266            n <- estimateFreeSlotsTBMQueue self
267            if n <= 0
268                then return (Just False)
269                else do
270                    writeTVar slots $! n - 1
271                    writeTQueue queue x
272                    return (Just True)
273
274
275-- | Put a data item back onto a queue, where it will be the next
276-- item read. If the queue is closed then the value is silently
277-- discarded; you can use 'peekTBMQueue' to circumvent this in certain
278-- circumstances. /N.B./, this could allow the queue to temporarily
279-- become longer than the specified limit, which is necessary to
280-- ensure that the item is indeed the next one read.
281unGetTBMQueue :: TBMQueue a -> a -> STM ()
282unGetTBMQueue (TBMQueue closed slots _reads queue) x = do
283    b <- readTVar closed
284    if b
285        then return () -- Discard silently
286        else do
287            modifyTVar' slots (subtract 1)
288            unGetTQueue queue x
289
290
291-- | Closes the @TBMQueue@, preventing any further writes.
292closeTBMQueue :: TBMQueue a -> STM ()
293closeTBMQueue (TBMQueue closed _slots _reads _queue) =
294    writeTVar closed True
295
296
297-- | Returns @True@ if the supplied @TBMQueue@ has been closed.
298isClosedTBMQueue :: TBMQueue a -> STM Bool
299isClosedTBMQueue (TBMQueue closed _slots _reads _queue) =
300    readTVar closed
301
302{-
303-- | Returns @True@ if the supplied @TBMQueue@ has been closed.
304isClosedTBMQueueIO :: TBMQueue a -> IO Bool
305isClosedTBMQueueIO (TBMQueue closed _slots _reads _queue) =
306    readTVarIO closed
307-}
308
309
310-- | Returns @True@ if the supplied @TBMQueue@ is empty (i.e., has
311-- no elements). /N.B./, a @TBMQueue@ can be both ``empty'' and
312-- ``full'' at the same time, if the initial limit was non-positive.
313isEmptyTBMQueue :: TBMQueue a -> STM Bool
314isEmptyTBMQueue (TBMQueue _closed _slots _reads queue) =
315    isEmptyTQueue queue
316
317
318-- | Returns @True@ if the supplied @TBMQueue@ is full (i.e., is
319-- over its limit). /N.B./, a @TBMQueue@ can be both ``empty'' and
320-- ``full'' at the same time, if the initial limit was non-positive.
321-- /N.B./, a @TBMQueue@ may still be full after reading, if
322-- 'unGetTBMQueue' was used to go over the initial limit.
323--
324-- This is equivalent to: @liftM (<= 0) estimateFreeSlotsTBMQueue@
325isFullTBMQueue :: TBMQueue a -> STM Bool
326isFullTBMQueue (TBMQueue _closed slots reads _queue) = do
327    n <- readTVar slots
328    if n <= 0
329        then do
330            m <- readTVar reads
331            let n' = n + m
332            writeTVar slots $! n'
333            writeTVar reads 0
334            return $! n' <= 0
335        else return False
336
337
338-- | Estimate the number of free slots. If the result is positive,
339-- then it's a minimum bound; if it's non-positive then it's exact.
340-- It will only be negative if the initial limit was negative or
341-- if 'unGetTBMQueue' was used to go over the initial limit.
342--
343-- This function always contends with writers, but only contends
344-- with readers when it has to; compare against 'freeSlotsTBMQueue'.
345estimateFreeSlotsTBMQueue :: TBMQueue a -> STM Int
346estimateFreeSlotsTBMQueue (TBMQueue _closed slots reads _queue) = do
347    n <- readTVar slots
348    if n > 0
349        then return n
350        else do
351            m <- readTVar reads
352            let n' = n + m
353            writeTVar slots $! n'
354            writeTVar reads 0
355            return n'
356
357
358-- | Return the exact number of free slots. The result can be
359-- negative if the initial limit was negative or if 'unGetTBMQueue'
360-- was used to go over the initial limit.
361--
362-- This function always contends with both readers and writers;
363-- compare against 'estimateFreeSlotsTBMQueue'.
364freeSlotsTBMQueue :: TBMQueue a -> STM Int
365freeSlotsTBMQueue (TBMQueue _closed slots reads _queue) = do
366    n <- readTVar slots
367    m <- readTVar reads
368    let n' = n + m
369    writeTVar slots $! n'
370    writeTVar reads 0
371    return n'
372
373----------------------------------------------------------------
374----------------------------------------------------------- fin.
375