stm-chans-3.0.0.9/0000755000000000000000000000000007346545000011747 5ustar0000000000000000stm-chans-3.0.0.9/AUTHORS0000644000000000000000000000111107346545000013011 0ustar0000000000000000=== Haskell stm-chans package AUTHORS/THANKS file === The stm-chans package was written (predominantly) by wren gayle romano and is released under the terms in the LICENSE file. I would also like to give thanks to the following contributers: Thomas DuBuisson --- For important improvements to TBChan and TBMChan, incorporating parts of his bounded-tchan package. These improvements reduce contention between readers and writers, improving throughput by 2--3 times when producers and consumers are running in separate OS threads. kudah --- For adding TQueue support. stm-chans-3.0.0.9/CHANGELOG0000644000000000000000000000425407346545000013166 0ustar00000000000000003.0.0.9 (2023-03-19): - Added `Tested-With: GHC == 9.6.1` (didn't actually need to nudge the upper bound on 'base', because it's already lenient) 3.0.0.8 (2022-08-28): - Added `Tested-With: GHC == 9.4.1` (didn't actually need to nudge the upper bound on 'base', because it's already lenient) 3.0.0.7 (2021-11-22): - Added `Tested-With: GHC == 9.2.1` (didn't actually need to nudge the upper bound on 'base', because it's already lenient) 3.0.0.6 (2021-10-17): - Removed old __HADDOCK__ hack - Updating stale emails, urls, etc 3.0.0.5 (2021-10-16): - Fixed the cabal file for Cabal >1.24 3.0.0.4 (2015-05-30): - Moved VERSION to CHANGELOG 3.0.0.3 (2015-03-29): - Cleaning up headers to compile cleanly with GHC 7.10 3.0.0 (2013-05-29): - Removed the deprecated compatibility modules. 2.1.0 (2013-05-29): - Added UNPACK pragmas everywhere to reduce indirections. - Added versions of newBroadcastT*Chan for TMChan - Deprecated all the compatibility stuff, since newBroadcastTChan requires stm >= 2.4 anyways. 2.0.0 (2013-05-12): - Add TQueue support 1.3.1 (2012-02-29): - Corrected the CPP macros now that stm-2.3 is released. 1.3.0 (2012-02-25): - Added Control.Concurrent.STM.TMVar.Compat 1.2.0.3 (2012-02-12): - Change stability from experimental to provisional. 1.2.0.2 (2012-02-12): - Documentation fix for Control.Concurrent.STM.TMChan.writeTMChan 1.2.0.1 (2011-05-07): - Moved old TBChan,TBMChan implementations to ./test/bench/ 1.2.0 (2011-05-07): - Various optimizations. - Switched to using 2 TVars in TBChan and TBMChan, reducing contention between readers and writers and improving throughput considerably (when multiple OS threads are used). - Control.Concurrent.STM.TBChan: added estimateFreeSlotsTBChan, freeSlotsTBChan - Control.Concurrent.STM.TBMChan: added estimateFreeSlotsTBMChan, freeSlotsTBMChan 1.1.0 (2011-04-05): - Control.Concurrent.STM.TBChan: added tryWriteTBChan - Control.Concurrent.STM.TBMChan: added tryWriteTBMChan 1.0.0 (2011-04-03): - Initial version forked from Posta-IPC. - Added tryRead* and tryPeek* functions for the various channels. stm-chans-3.0.0.9/LICENSE0000644000000000000000000000305007346545000012752 0ustar0000000000000000=== stm-chans license === Copyright (c) 2011--2013, wren gayle romano. ALL RIGHTS RESERVED. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the copyright holders nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. stm-chans-3.0.0.9/README.md0000644000000000000000000000353507346545000013234 0ustar0000000000000000stm-chans ========= [![Hackage version](https://img.shields.io/hackage/v/stm-chans.svg?style=flat)](https://hackage.haskell.org/package/stm-chans) [![Build Status](https://github.com/wrengr/stm-chans/workflows/ci/badge.svg)](https://github.com/wrengr/stm-chans/actions?query=workflow%3Aci) [![Dependencies](https://img.shields.io/hackage-deps/v/stm-chans.svg?style=flat)](http://packdeps.haskellers.com/specific?package=stm-chans) This package offers a collection of channel types, similar to `Control.Concurrent.STM.{TChan,TQueue}` but with additional features. In particular we offer the following data types: * `Control.Concurrent.STM.TBChan`: Bounded FIFO channels. When the channel is full, writers will block/retry. This ensures that the writers do not get too far ahead of the readers, which helps to make sure that memory and cpu resources are used responsibly. * `Control.Concurrent.STM.TMChan`: Closeable FIFO channels. * `Control.Concurrent.STM.TMQueue`: Closeable FIFO queues. Like `TChan (Maybe a)` but with a monotonicity guarantee that once `Nothing` is returned all future reads will be `Nothing` as well. * `Control.Concurrent.STM.TBMChan`: Bounded Closeable FIFO channels. * `Control.Concurrent.STM.TBMQueue`: Bounded Closeable FIFO queues. Combines the capabilities of `TBChan` and `TMChan`. ## Install In general, this is a simple package and should be easy to install. It does require GHC however, because it relies on the Control.Concurrent.STM.TChan type which (for some unknown reason) is GHC-only. With the cabal-install program you can just do: $> cabal install stm-chans ## Links * [Website](http://wrengr.org/) * [Blog](http://winterkoninkje.dreamwidth.org/) * [Twitter](https://twitter.com/wrengr) * [Hackage](http://hackage.haskell.org/package/stm-chans) * [GitHub](https://github.com/wrengr/stm-chans) stm-chans-3.0.0.9/Setup.hs0000644000000000000000000000016207346545000013402 0ustar0000000000000000#!/usr/bin/env runhaskell module Main (main) where import Distribution.Simple main :: IO () main = defaultMain stm-chans-3.0.0.9/src/Control/Concurrent/STM/0000755000000000000000000000000007346545000016743 5ustar0000000000000000stm-chans-3.0.0.9/src/Control/Concurrent/STM/TBChan.hs0000644000000000000000000002050207346545000020375 0ustar0000000000000000{-# OPTIONS_GHC -Wall -fwarn-tabs #-} {-# LANGUAGE CPP, DeriveDataTypeable #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Safe #-} #endif ---------------------------------------------------------------- -- 2021.10.17 -- | -- Module : Control.Concurrent.STM.TBChan -- Copyright : Copyright (c) 2011--2021 wren gayle romano -- License : BSD -- Maintainer : wren@cpan.org -- Stability : provisional -- Portability : non-portable (GHC STM, DeriveDataTypeable) -- -- A version of "Control.Concurrent.STM.TChan" where the queue is -- bounded in length. This variant incorporates ideas from Thomas -- M. DuBuisson's @bounded-tchan@ package in order to reduce -- contention between readers and writers. ---------------------------------------------------------------- module Control.Concurrent.STM.TBChan ( -- * The TBChan type TBChan() -- ** Creating TBChans , newTBChan , newTBChanIO -- I don't know how to define dupTBChan with the correct semantics -- ** Reading from TBChans , readTBChan , tryReadTBChan , peekTBChan , tryPeekTBChan -- ** Writing to TBChans , writeTBChan , tryWriteTBChan , unGetTBChan -- ** Predicates , isEmptyTBChan , isFullTBChan -- ** Other functionality , estimateFreeSlotsTBChan , freeSlotsTBChan ) where import Prelude hiding (reads) import Data.Typeable (Typeable) import Control.Monad.STM (STM, retry) import Control.Concurrent.STM.TVar import Control.Concurrent.STM.TChan -- N.B., GHC only ---------------------------------------------------------------- -- | @TBChan@ is an abstract type representing a bounded FIFO -- channel. data TBChan a = TBChan {-# UNPACK #-} !(TVar Int) {-# UNPACK #-} !(TVar Int) {-# UNPACK #-} !(TChan a) deriving (Typeable) -- The components are: -- * How many free slots we /know/ we have available. -- * How many slots have been freed up by successful reads since -- the last time the slot count was synchronized by 'isFullTBChan'. -- * The underlying TChan. -- | Build and returns a new instance of @TBChan@ with the given -- capacity. /N.B./, we do not verify the capacity is positive, but -- if it is non-positive then 'writeTBChan' will always retry and -- 'isFullTBChan' will always be true. newTBChan :: Int -> STM (TBChan a) newTBChan n = do slots <- newTVar n reads <- newTVar 0 chan <- newTChan return (TBChan slots reads chan) -- | @IO@ version of 'newTBChan'. This is useful for creating -- top-level @TBChan@s using 'System.IO.Unsafe.unsafePerformIO', -- because using 'Control.Monad.STM.atomically' inside -- 'System.IO.Unsafe.unsafePerformIO' isn't possible. newTBChanIO :: Int -> IO (TBChan a) newTBChanIO n = do slots <- newTVarIO n reads <- newTVarIO 0 chan <- newTChanIO return (TBChan slots reads chan) -- | Read the next value from the @TBChan@, retrying if the channel -- is empty. readTBChan :: TBChan a -> STM a readTBChan (TBChan _slots reads chan) = do x <- readTChan chan modifyTVar' reads (1 +) return x -- | A version of 'readTBChan' which does not retry. Instead it -- returns @Nothing@ if no value is available. tryReadTBChan :: TBChan a -> STM (Maybe a) tryReadTBChan (TBChan _slots reads chan) = do mx <- tryReadTChan chan case mx of Nothing -> return Nothing Just _x -> do modifyTVar' reads (1 +) return mx -- | Get the next value from the @TBChan@ without removing it, -- retrying if the channel is empty. peekTBChan :: TBChan a -> STM a peekTBChan (TBChan _slots _reads chan) = peekTChan chan -- | A version of 'peekTBChan' which does not retry. Instead it -- returns @Nothing@ if no value is available. tryPeekTBChan :: TBChan a -> STM (Maybe a) tryPeekTBChan (TBChan _slots _reads chan) = tryPeekTChan chan -- | Write a value to a @TBChan@, retrying if the channel is full. writeTBChan :: TBChan a -> a -> STM () writeTBChan self@(TBChan slots _reads chan) x = do n <- estimateFreeSlotsTBChan self if n <= 0 then retry else do writeTVar slots $! n - 1 writeTChan chan x {- -- The above comparison is unnecessary on one of the n>0 branches -- coming from estimateFreeSlotsTBChan. But for some reason, trying -- to remove it can cause BlockedIndefinatelyOnSTM exceptions. -- The above saves one @readTVar slots@ compared to: writeTBChan self@(TBChan slots _reads chan) x = do b <- isFullTBChan self if b then retry else do modifyTVar' slots (subtract 1) writeTChan chan x -} -- | A version of 'writeTBChan' which does not retry. Returns @True@ -- if the value was successfully written, and @False@ otherwise. tryWriteTBChan :: TBChan a -> a -> STM Bool tryWriteTBChan self@(TBChan slots _reads chan) x = do n <- estimateFreeSlotsTBChan self if n <= 0 then return False else do writeTVar slots $! n - 1 writeTChan chan x return True {- -- The above comparison is unnecessary on one of the n>0 branches -- coming from estimateFreeSlotsTBChan. But for some reason, trying -- to remove it can cause BlockedIndefinatelyOnSTM exceptions. -- The above saves one @readTVar slots@ compared to: tryWriteTBChan self@(TBChan slots _reads chan) x = do b <- isFullTBChan self if b then return False else do modifyTVar' slots (subtract 1) writeTChan chan x return True -} -- | Put a data item back onto a channel, where it will be the next -- item read. /N.B./, this could allow the channel to temporarily -- become longer than the specified limit, which is necessary to -- ensure that the item is indeed the next one read. unGetTBChan :: TBChan a -> a -> STM () unGetTBChan (TBChan slots _reads chan) x = do modifyTVar' slots (subtract 1) unGetTChan chan x -- | Returns @True@ if the supplied @TBChan@ is empty (i.e., has -- no elements). /N.B./, a @TBChan@ can be both \"empty\" and -- \"full\" at the same time, if the initial limit was non-positive. isEmptyTBChan :: TBChan a -> STM Bool isEmptyTBChan (TBChan _slots _reads chan) = isEmptyTChan chan -- | Returns @True@ if the supplied @TBChan@ is full (i.e., is over -- its limit). /N.B./, a @TBChan@ can be both \"empty\" and \"full\" -- at the same time, if the initial limit was non-positive. /N.B./, -- a @TBChan@ may still be full after reading, if 'unGetTBChan' was -- used to go over the initial limit. -- -- This is equivalent to: @liftM (<= 0) estimateFreeSlotsTBMChan@ isFullTBChan :: TBChan a -> STM Bool isFullTBChan (TBChan slots reads _chan) = do n <- readTVar slots if n <= 0 then do m <- readTVar reads let n' = n + m writeTVar slots $! n' writeTVar reads 0 return $! n' <= 0 else return False {- -- The above saves an extraneous comparison of n\/n' against 0 -- compared to the more obvious: isFullTBChan self = do n <- estimateFreeSlotsTBChan self return $! n <= 0 -} -- | Estimate the number of free slots. If the result is positive, -- then it's a minimum bound; if it's non-positive then it's exact. -- It will only be negative if the initial limit was negative or -- if 'unGetTBChan' was used to go over the initial limit. -- -- This function always contends with writers, but only contends -- with readers when it has to; compare against 'freeSlotsTBChan'. estimateFreeSlotsTBChan :: TBChan a -> STM Int estimateFreeSlotsTBChan (TBChan slots reads _chan) = do n <- readTVar slots if n > 0 then return n else do m <- readTVar reads let n' = n + m writeTVar slots $! n' writeTVar reads 0 return n' -- | Return the exact number of free slots. The result can be -- negative if the initial limit was negative or if 'unGetTBChan' -- was used to go over the initial limit. -- -- This function always contends with both readers and writers; -- compare against 'estimateFreeSlotsTBChan'. freeSlotsTBChan :: TBChan a -> STM Int freeSlotsTBChan (TBChan slots reads _chan) = do n <- readTVar slots m <- readTVar reads let n' = n + m writeTVar slots $! n' writeTVar reads 0 return n' ---------------------------------------------------------------- ----------------------------------------------------------- fin. stm-chans-3.0.0.9/src/Control/Concurrent/STM/TBMChan.hs0000644000000000000000000002774207346545000020527 0ustar0000000000000000{-# OPTIONS_GHC -Wall -fwarn-tabs #-} {-# LANGUAGE CPP, DeriveDataTypeable #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Safe #-} #endif ---------------------------------------------------------------- -- 2021.10.17 -- | -- Module : Control.Concurrent.STM.TBMChan -- Copyright : Copyright (c) 2011--2021 wren gayle romano -- License : BSD -- Maintainer : wren@cpan.org -- Stability : provisional -- Portability : non-portable (GHC STM, DeriveDataTypeable) -- -- A version of "Control.Concurrent.STM.TChan" where the queue is -- bounded in length and closeable. This combines the abilities of -- "Control.Concurrent.STM.TBChan" and "Control.Concurrent.STM.TMChan". -- This variant incorporates ideas from Thomas M. DuBuisson's -- @bounded-tchan@ package in order to reduce contention between -- readers and writers. ---------------------------------------------------------------- module Control.Concurrent.STM.TBMChan ( -- * The TBMChan type TBMChan() -- ** Creating TBMChans , newTBMChan , newTBMChanIO -- I don't know how to define dupTBMChan with the correct semantics -- ** Reading from TBMChans , readTBMChan , tryReadTBMChan , peekTBMChan , tryPeekTBMChan -- ** Writing to TBMChans , writeTBMChan , tryWriteTBMChan , unGetTBMChan -- ** Closing TBMChans , closeTBMChan -- ** Predicates , isClosedTBMChan , isEmptyTBMChan , isFullTBMChan -- ** Other functionality , estimateFreeSlotsTBMChan , freeSlotsTBMChan ) where import Prelude hiding (reads) import Data.Typeable (Typeable) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif import Control.Monad.STM (STM, retry) import Control.Concurrent.STM.TVar import Control.Concurrent.STM.TChan -- N.B., GHC only ---------------------------------------------------------------- -- | @TBMChan@ is an abstract type representing a bounded closeable -- FIFO channel. data TBMChan a = TBMChan {-# UNPACK #-} !(TVar Bool) {-# UNPACK #-} !(TVar Int) {-# UNPACK #-} !(TVar Int) {-# UNPACK #-} !(TChan a) deriving (Typeable) -- The components are: -- * Whether the channel has been closed. -- * How many free slots we /know/ we have available. -- * How many slots have been freed up by successful reads since -- the last time the slot count was synchronized by 'isFullTBChan'. -- * The underlying TChan. -- | Build and returns a new instance of @TBMChan@ with the given -- capacity. /N.B./, we do not verify the capacity is positive, but -- if it is non-positive then 'writeTBMChan' will always retry and -- 'isFullTBMChan' will always be true. newTBMChan :: Int -> STM (TBMChan a) newTBMChan n = do closed <- newTVar False slots <- newTVar n reads <- newTVar 0 chan <- newTChan return (TBMChan closed slots reads chan) -- | @IO@ version of 'newTBMChan'. This is useful for creating -- top-level @TBMChan@s using 'System.IO.Unsafe.unsafePerformIO', -- because using 'Control.Monad.STM.atomically' inside -- 'System.IO.Unsafe.unsafePerformIO' isn't possible. newTBMChanIO :: Int -> IO (TBMChan a) newTBMChanIO n = do closed <- newTVarIO False slots <- newTVarIO n reads <- newTVarIO 0 chan <- newTChanIO return (TBMChan closed slots reads chan) -- | Read the next value from the @TBMChan@, retrying if the channel -- is empty (and not closed). We return @Nothing@ immediately if -- the channel is closed and empty. readTBMChan :: TBMChan a -> STM (Maybe a) readTBMChan (TBMChan closed _slots reads chan) = do b <- readTVar closed if b then do mx <- tryReadTChan chan case mx of Nothing -> return mx Just _x -> do modifyTVar' reads (1 +) return mx else do x <- readTChan chan modifyTVar' reads (1 +) return (Just x) {- -- The above is slightly optimized over the clearer: readTBMChan (TBMChan closed _slots reads chan) = b <- readTVar closed b' <- isEmptyTChan chan if b && b' then return Nothing else do x <- readTChan chan modifyTVar' reads (1 +) return (Just x) -- TODO: compare Core and benchmarks; is the loss of clarity worth it? -} -- | A version of 'readTBMChan' which does not retry. Instead it -- returns @Just Nothing@ if the channel is open but no value is -- available; it still returns @Nothing@ if the channel is closed -- and empty. tryReadTBMChan :: TBMChan a -> STM (Maybe (Maybe a)) tryReadTBMChan (TBMChan closed _slots reads chan) = do b <- readTVar closed if b then do mx <- tryReadTChan chan case mx of Nothing -> return Nothing Just _x -> do modifyTVar' reads (1 +) return (Just mx) else do mx <- tryReadTChan chan case mx of Nothing -> return (Just mx) Just _x -> do modifyTVar' reads (1 +) return (Just mx) {- -- The above is slightly optimized over the clearer: tryReadTBMChan (TBMChan closed _slots reads chan) = b <- readTVar closed b' <- isEmptyTChan chan if b && b' then return Nothing else do mx <- tryReadTBMChan chan case mx of Nothing -> return (Just mx) Just _x -> do modifyTVar' reads (1 +) return (Just mx) -- TODO: compare Core and benchmarks; is the loss of clarity worth it? -} -- | Get the next value from the @TBMChan@ without removing it, -- retrying if the channel is empty. peekTBMChan :: TBMChan a -> STM (Maybe a) peekTBMChan (TBMChan closed _slots _reads chan) = do b <- readTVar closed if b then do b' <- isEmptyTChan chan if b' then return Nothing else Just <$> peekTChan chan else Just <$> peekTChan chan {- -- The above is lazier reading from @chan@ than the clearer: peekTBMChan (TBMChan closed _slots _reads chan) = do b <- isEmptyTChan chan b' <- readTVar closed if b && b' then return Nothing else Just <$> peekTChan chan -- TODO: compare Core and benchmarks; is the loss of clarity worth it? -} -- | A version of 'peekTBMChan' which does not retry. Instead it -- returns @Just Nothing@ if the channel is open but no value is -- available; it still returns @Nothing@ if the channel is closed -- and empty. tryPeekTBMChan :: TBMChan a -> STM (Maybe (Maybe a)) tryPeekTBMChan (TBMChan closed _slots _reads chan) = do b <- readTVar closed if b then fmap Just <$> tryPeekTChan chan else Just <$> tryPeekTChan chan {- -- The above is lazier reading from @chan@ (and removes an extraneous isEmptyTChan when using the compatibility layer) than the clearer: tryPeekTBMChan (TBMChan closed _slots _reads chan) = do b <- isEmptyTChan chan b' <- readTVar closed if b && b' then return Nothing else Just <$> tryPeekTChan chan -- TODO: compare Core and benchmarks; is the loss of clarity worth it? -} -- | Write a value to a @TBMChan@, retrying if the channel is full. -- If the channel is closed then the value is silently discarded. -- Use 'isClosedTBMChan' to determine if the channel is closed -- before writing, as needed. writeTBMChan :: TBMChan a -> a -> STM () writeTBMChan self@(TBMChan closed slots _reads chan) x = do b <- readTVar closed if b then return () -- Discard silently else do n <- estimateFreeSlotsTBMChan self if n <= 0 then retry else do writeTVar slots $! n - 1 writeTChan chan x -- | A version of 'writeTBMChan' which does not retry. Returns @Just -- True@ if the value was successfully written, @Just False@ if it -- could not be written (but the channel was open), and @Nothing@ -- if it was discarded (i.e., the channel was closed). tryWriteTBMChan :: TBMChan a -> a -> STM (Maybe Bool) tryWriteTBMChan self@(TBMChan closed slots _reads chan) x = do b <- readTVar closed if b then return Nothing else do n <- estimateFreeSlotsTBMChan self if n <= 0 then return (Just False) else do writeTVar slots $! n - 1 writeTChan chan x return (Just True) -- | Put a data item back onto a channel, where it will be the next -- item read. If the channel is closed then the value is silently -- discarded; you can use 'peekTBMChan' to circumvent this in certain -- circumstances. /N.B./, this could allow the channel to temporarily -- become longer than the specified limit, which is necessary to -- ensure that the item is indeed the next one read. unGetTBMChan :: TBMChan a -> a -> STM () unGetTBMChan (TBMChan closed slots _reads chan) x = do b <- readTVar closed if b then return () -- Discard silently else do modifyTVar' slots (subtract 1) unGetTChan chan x -- | Closes the @TBMChan@, preventing any further writes. closeTBMChan :: TBMChan a -> STM () closeTBMChan (TBMChan closed _slots _reads _chan) = writeTVar closed True -- | Returns @True@ if the supplied @TBMChan@ has been closed. isClosedTBMChan :: TBMChan a -> STM Bool isClosedTBMChan (TBMChan closed _slots _reads _chan) = readTVar closed {- -- | Returns @True@ if the supplied @TBMChan@ has been closed. isClosedTBMChanIO :: TBMChan a -> IO Bool isClosedTBMChanIO (TBMChan closed _slots _reads _chan) = readTVarIO closed -} -- | Returns @True@ if the supplied @TBMChan@ is empty (i.e., has -- no elements). /N.B./, a @TBMChan@ can be both \"empty\" and -- \"full\" at the same time, if the initial limit was non-positive. isEmptyTBMChan :: TBMChan a -> STM Bool isEmptyTBMChan (TBMChan _closed _slots _reads chan) = isEmptyTChan chan -- | Returns @True@ if the supplied @TBMChan@ is full (i.e., is -- over its limit). /N.B./, a @TBMChan@ can be both \"empty\" and -- \"full\" at the same time, if the initial limit was non-positive. -- /N.B./, a @TBMChan@ may still be full after reading, if -- 'unGetTBMChan' was used to go over the initial limit. -- -- This is equivalent to: @liftM (<= 0) estimateFreeSlotsTBMChan@ isFullTBMChan :: TBMChan a -> STM Bool isFullTBMChan (TBMChan _closed slots reads _chan) = do n <- readTVar slots if n <= 0 then do m <- readTVar reads let n' = n + m writeTVar slots $! n' writeTVar reads 0 return $! n' <= 0 else return False -- | Estimate the number of free slots. If the result is positive, -- then it's a minimum bound; if it's non-positive then it's exact. -- It will only be negative if the initial limit was negative or -- if 'unGetTBMChan' was used to go over the initial limit. -- -- This function always contends with writers, but only contends -- with readers when it has to; compare against 'freeSlotsTBMChan'. estimateFreeSlotsTBMChan :: TBMChan a -> STM Int estimateFreeSlotsTBMChan (TBMChan _closed slots reads _chan) = do n <- readTVar slots if n > 0 then return n else do m <- readTVar reads let n' = n + m writeTVar slots $! n' writeTVar reads 0 return n' -- | Return the exact number of free slots. The result can be -- negative if the initial limit was negative or if 'unGetTBMChan' -- was used to go over the initial limit. -- -- This function always contends with both readers and writers; -- compare against 'estimateFreeSlotsTBMChan'. freeSlotsTBMChan :: TBMChan a -> STM Int freeSlotsTBMChan (TBMChan _closed slots reads _chan) = do n <- readTVar slots m <- readTVar reads let n' = n + m writeTVar slots $! n' writeTVar reads 0 return n' ---------------------------------------------------------------- ----------------------------------------------------------- fin. stm-chans-3.0.0.9/src/Control/Concurrent/STM/TBMQueue.hs0000644000000000000000000002767707346545000020751 0ustar0000000000000000{-# OPTIONS_GHC -Wall -fwarn-tabs #-} {-# LANGUAGE CPP, DeriveDataTypeable #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Safe #-} #endif ---------------------------------------------------------------- -- 2021.10.17 -- | -- Module : Control.Concurrent.STM.TBMQueue -- Copyright : Copyright (c) 2011--2021 wren gayle romano -- License : BSD -- Maintainer : wren@cpan.org -- Stability : provisional -- Portability : non-portable (GHC STM, DeriveDataTypeable) -- -- A version of "Control.Concurrent.STM.TQueue" where the queue is -- bounded in length and closeable. This combines the abilities of -- "Control.Concurrent.STM.TBQueue" and "Control.Concurrent.STM.TMQueue". -- -- /Since: 2.0.0/ ---------------------------------------------------------------- module Control.Concurrent.STM.TBMQueue ( -- * The TBMQueue type TBMQueue() -- ** Creating TBMQueues , newTBMQueue , newTBMQueueIO -- ** Reading from TBMQueues , readTBMQueue , tryReadTBMQueue , peekTBMQueue , tryPeekTBMQueue -- ** Writing to TBMQueues , writeTBMQueue , tryWriteTBMQueue , unGetTBMQueue -- ** Closing TBMQueues , closeTBMQueue -- ** Predicates , isClosedTBMQueue , isEmptyTBMQueue , isFullTBMQueue -- ** Other functionality , estimateFreeSlotsTBMQueue , freeSlotsTBMQueue ) where import Prelude hiding (reads) import Data.Typeable (Typeable) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif import Control.Monad.STM (STM, retry) import Control.Concurrent.STM.TVar import Control.Concurrent.STM.TQueue -- N.B., GHC only ---------------------------------------------------------------- -- | @TBMQueue@ is an abstract type representing a bounded closeable -- FIFO queue. data TBMQueue a = TBMQueue {-# UNPACK #-} !(TVar Bool) {-# UNPACK #-} !(TVar Int) {-# UNPACK #-} !(TVar Int) {-# UNPACK #-} !(TQueue a) deriving (Typeable) -- The components are: -- * Whether the queue has been closed. -- * How many free slots we /know/ we have available. -- * How many slots have been freed up by successful reads since -- the last time the slot count was synchronized by 'isFullTBQueue'. -- * The underlying TQueue. -- | Build and returns a new instance of @TBMQueue@ with the given -- capacity. /N.B./, we do not verify the capacity is positive, but -- if it is non-positive then 'writeTBMQueue' will always retry and -- 'isFullTBMQueue' will always be true. newTBMQueue :: Int -> STM (TBMQueue a) newTBMQueue n = do closed <- newTVar False slots <- newTVar n reads <- newTVar 0 queue <- newTQueue return (TBMQueue closed slots reads queue) -- | @IO@ version of 'newTBMQueue'. This is useful for creating -- top-level @TBMQueue@s using 'System.IO.Unsafe.unsafePerformIO', -- because using 'Control.Monad.STM.atomically' inside -- 'System.IO.Unsafe.unsafePerformIO' isn't possible. newTBMQueueIO :: Int -> IO (TBMQueue a) newTBMQueueIO n = do closed <- newTVarIO False slots <- newTVarIO n reads <- newTVarIO 0 queue <- newTQueueIO return (TBMQueue closed slots reads queue) -- | Read the next value from the @TBMQueue@, retrying if the queue -- is empty (and not closed). We return @Nothing@ immediately if -- the queue is closed and empty. readTBMQueue :: TBMQueue a -> STM (Maybe a) readTBMQueue (TBMQueue closed _slots reads queue) = do b <- readTVar closed if b then do mx <- tryReadTQueue queue case mx of Nothing -> return mx Just _x -> do modifyTVar' reads (1 +) return mx else do x <- readTQueue queue modifyTVar' reads (1 +) return (Just x) {- -- The above is slightly optimized over the clearer: readTBMQueue (TBMQueue closed _slots reads queue) = b <- readTVar closed b' <- isEmptyTQueue queue if b && b' then return Nothing else do x <- readTQueue queue modifyTVar' reads (1 +) return (Just x) -- TODO: compare Core and benchmarks; is the loss of clarity worth it? -} -- | A version of 'readTBMQueue' which does not retry. Instead it -- returns @Just Nothing@ if the queue is open but no value is -- available; it still returns @Nothing@ if the queue is closed -- and empty. tryReadTBMQueue :: TBMQueue a -> STM (Maybe (Maybe a)) tryReadTBMQueue (TBMQueue closed _slots reads queue) = do b <- readTVar closed if b then do mx <- tryReadTQueue queue case mx of Nothing -> return Nothing Just _x -> do modifyTVar' reads (1 +) return (Just mx) else do mx <- tryReadTQueue queue case mx of Nothing -> return (Just mx) Just _x -> do modifyTVar' reads (1 +) return (Just mx) {- -- The above is slightly optimized over the clearer: tryReadTBMQueue (TBMQueue closed _slots reads queue) = b <- readTVar closed b' <- isEmptyTQueue queue if b && b' then return Nothing else do mx <- tryReadTBMQueue queue case mx of Nothing -> return (Just mx) Just _x -> do modifyTVar' reads (1 +) return (Just mx) -- TODO: compare Core and benchmarks; is the loss of clarity worth it? -} -- | Get the next value from the @TBMQueue@ without removing it, -- retrying if the queue is empty. peekTBMQueue :: TBMQueue a -> STM (Maybe a) peekTBMQueue (TBMQueue closed _slots _reads queue) = do b <- readTVar closed if b then do b' <- isEmptyTQueue queue if b' then return Nothing else Just <$> peekTQueue queue else Just <$> peekTQueue queue {- -- The above is lazier reading from @queue@ than the clearer: peekTBMQueue (TBMQueue closed _slots _reads queue) = do b <- isEmptyTQueue queue b' <- readTVar closed if b && b' then return Nothing else Just <$> peekTQueue queue -- TODO: compare Core and benchmarks; is the loss of clarity worth it? -} -- | A version of 'peekTBMQueue' which does not retry. Instead it -- returns @Just Nothing@ if the queue is open but no value is -- available; it still returns @Nothing@ if the queue is closed -- and empty. tryPeekTBMQueue :: TBMQueue a -> STM (Maybe (Maybe a)) tryPeekTBMQueue (TBMQueue closed _slots _reads queue) = do b <- readTVar closed if b then fmap Just <$> tryPeekTQueue queue else Just <$> tryPeekTQueue queue {- -- The above is lazier reading from @queue@ (and removes an extraneous isEmptyTQueue when using the compatibility layer) than the clearer: tryPeekTBMQueue (TBMQueue closed _slots _reads queue) = do b <- isEmptyTQueue queue b' <- readTVar closed if b && b' then return Nothing else Just <$> tryPeekTQueue queue -- TODO: compare Core and benchmarks; is the loss of clarity worth it? -} -- | Write a value to a @TBMQueue@, retrying if the queue is full. -- If the queue is closed then the value is silently discarded. -- Use 'isClosedTBMQueue' to determine if the queue is closed -- before writing, as needed. writeTBMQueue :: TBMQueue a -> a -> STM () writeTBMQueue self@(TBMQueue closed slots _reads queue) x = do b <- readTVar closed if b then return () -- Discard silently else do n <- estimateFreeSlotsTBMQueue self if n <= 0 then retry else do writeTVar slots $! n - 1 writeTQueue queue x -- | A version of 'writeTBMQueue' which does not retry. Returns @Just -- True@ if the value was successfully written, @Just False@ if it -- could not be written (but the queue was open), and @Nothing@ -- if it was discarded (i.e., the queue was closed). tryWriteTBMQueue :: TBMQueue a -> a -> STM (Maybe Bool) tryWriteTBMQueue self@(TBMQueue closed slots _reads queue) x = do b <- readTVar closed if b then return Nothing else do n <- estimateFreeSlotsTBMQueue self if n <= 0 then return (Just False) else do writeTVar slots $! n - 1 writeTQueue queue x return (Just True) -- | Put a data item back onto a queue, where it will be the next -- item read. If the queue is closed then the value is silently -- discarded; you can use 'peekTBMQueue' to circumvent this in certain -- circumstances. /N.B./, this could allow the queue to temporarily -- become longer than the specified limit, which is necessary to -- ensure that the item is indeed the next one read. unGetTBMQueue :: TBMQueue a -> a -> STM () unGetTBMQueue (TBMQueue closed slots _reads queue) x = do b <- readTVar closed if b then return () -- Discard silently else do modifyTVar' slots (subtract 1) unGetTQueue queue x -- | Closes the @TBMQueue@, preventing any further writes. closeTBMQueue :: TBMQueue a -> STM () closeTBMQueue (TBMQueue closed _slots _reads _queue) = writeTVar closed True -- | Returns @True@ if the supplied @TBMQueue@ has been closed. isClosedTBMQueue :: TBMQueue a -> STM Bool isClosedTBMQueue (TBMQueue closed _slots _reads _queue) = readTVar closed {- -- | Returns @True@ if the supplied @TBMQueue@ has been closed. isClosedTBMQueueIO :: TBMQueue a -> IO Bool isClosedTBMQueueIO (TBMQueue closed _slots _reads _queue) = readTVarIO closed -} -- | Returns @True@ if the supplied @TBMQueue@ is empty (i.e., has -- no elements). /N.B./, a @TBMQueue@ can be both \"empty\" and -- \"full\" at the same time, if the initial limit was non-positive. isEmptyTBMQueue :: TBMQueue a -> STM Bool isEmptyTBMQueue (TBMQueue _closed _slots _reads queue) = isEmptyTQueue queue -- | Returns @True@ if the supplied @TBMQueue@ is full (i.e., is -- over its limit). /N.B./, a @TBMQueue@ can be both \"empty\" and -- \"full\" at the same time, if the initial limit was non-positive. -- /N.B./, a @TBMQueue@ may still be full after reading, if -- 'unGetTBMQueue' was used to go over the initial limit. -- -- This is equivalent to: @liftM (<= 0) estimateFreeSlotsTBMQueue@ isFullTBMQueue :: TBMQueue a -> STM Bool isFullTBMQueue (TBMQueue _closed slots reads _queue) = do n <- readTVar slots if n <= 0 then do m <- readTVar reads let n' = n + m writeTVar slots $! n' writeTVar reads 0 return $! n' <= 0 else return False -- | Estimate the number of free slots. If the result is positive, -- then it's a minimum bound; if it's non-positive then it's exact. -- It will only be negative if the initial limit was negative or -- if 'unGetTBMQueue' was used to go over the initial limit. -- -- This function always contends with writers, but only contends -- with readers when it has to; compare against 'freeSlotsTBMQueue'. estimateFreeSlotsTBMQueue :: TBMQueue a -> STM Int estimateFreeSlotsTBMQueue (TBMQueue _closed slots reads _queue) = do n <- readTVar slots if n > 0 then return n else do m <- readTVar reads let n' = n + m writeTVar slots $! n' writeTVar reads 0 return n' -- | Return the exact number of free slots. The result can be -- negative if the initial limit was negative or if 'unGetTBMQueue' -- was used to go over the initial limit. -- -- This function always contends with both readers and writers; -- compare against 'estimateFreeSlotsTBMQueue'. freeSlotsTBMQueue :: TBMQueue a -> STM Int freeSlotsTBMQueue (TBMQueue _closed slots reads _queue) = do n <- readTVar slots m <- readTVar reads let n' = n + m writeTVar slots $! n' writeTVar reads 0 return n' ---------------------------------------------------------------- ----------------------------------------------------------- fin. stm-chans-3.0.0.9/src/Control/Concurrent/STM/TMChan.hs0000644000000000000000000001720007346545000020411 0ustar0000000000000000{-# OPTIONS_GHC -Wall -fwarn-tabs #-} {-# LANGUAGE CPP, DeriveDataTypeable #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Safe #-} #endif ---------------------------------------------------------------- -- 2021.10.17 -- | -- Module : Control.Concurrent.STM.TMChan -- Copyright : Copyright (c) 2011--2021 wren gayle romano -- License : BSD -- Maintainer : wren@cpan.org -- Stability : provisional -- Portability : non-portable (GHC STM, DeriveDataTypeable) -- -- A version of "Control.Concurrent.STM.TChan" where the queue is -- closeable. This is similar to a @TChan (Maybe a)@ with a -- monotonicity guarantee that once there's a @Nothing@ there will -- always be @Nothing@. ---------------------------------------------------------------- module Control.Concurrent.STM.TMChan ( -- * The TMChan type TMChan() -- ** Creating TMChans , newTMChan , newTMChanIO , dupTMChan , newBroadcastTMChan , newBroadcastTMChanIO -- ** Reading from TMChans , readTMChan , tryReadTMChan , peekTMChan , tryPeekTMChan -- ** Writing to TMChans , writeTMChan , unGetTMChan -- ** Closing TMChans , closeTMChan -- ** Predicates , isClosedTMChan , isEmptyTMChan ) where import Data.Typeable (Typeable) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif import Control.Monad.STM (STM) import Control.Concurrent.STM.TVar import Control.Concurrent.STM.TChan -- N.B., GHC only ---------------------------------------------------------------- -- | @TMChan@ is an abstract type representing a closeable FIFO -- channel. data TMChan a = TMChan {-# UNPACK #-} !(TVar Bool) {-# UNPACK #-} !(TChan a) deriving Typeable -- | Build and returns a new instance of @TMChan@. newTMChan :: STM (TMChan a) newTMChan = do closed <- newTVar False chan <- newTChan return (TMChan closed chan) -- | @IO@ version of 'newTMChan'. This is useful for creating -- top-level @TMChan@s using 'System.IO.Unsafe.unsafePerformIO', -- because using 'Control.Monad.STM.atomically' inside -- 'System.IO.Unsafe.unsafePerformIO' isn't possible. newTMChanIO :: IO (TMChan a) newTMChanIO = do closed <- newTVarIO False chan <- newTChanIO return (TMChan closed chan) -- | Like 'newBroadcastTChan'. -- -- /Since: 2.1.0/ newBroadcastTMChan :: STM (TMChan a) newBroadcastTMChan = do closed <- newTVar False chan <- newBroadcastTChan return (TMChan closed chan) -- | @IO@ version of 'newBroadcastTMChan'. -- -- /Since: 2.1.0/ newBroadcastTMChanIO :: IO (TMChan a) newBroadcastTMChanIO = do closed <- newTVarIO False chan <- newBroadcastTChanIO return (TMChan closed chan) -- | Duplicate a @TMChan@: the duplicate channel begins empty, but -- data written to either channel from then on will be available -- from both, and closing one copy will close them all. Hence this -- creates a kind of broadcast channel, where data written by anyone -- is seen by everyone else. dupTMChan :: TMChan a -> STM (TMChan a) dupTMChan (TMChan closed chan) = do new_chan <- dupTChan chan return (TMChan closed new_chan) -- | Read the next value from the @TMChan@, retrying if the channel -- is empty (and not closed). We return @Nothing@ immediately if -- the channel is closed and empty. readTMChan :: TMChan a -> STM (Maybe a) readTMChan (TMChan closed chan) = do b <- readTVar closed if b then tryReadTChan chan else Just <$> readTChan chan {- -- The above is lazier reading from @chan@, and slightly optimized, compared to the clearer: readTMChan (TMChan closed chan) = do b <- isEmptyTChan chan b' <- readTVar closed if b && b' then return Nothing else Just <$> readTChan chan -- TODO: compare Core and benchmarks; is the loss of clarity worth it? -} -- | A version of 'readTMChan' which does not retry. Instead it -- returns @Just Nothing@ if the channel is open but no value is -- available; it still returns @Nothing@ if the channel is closed -- and empty. tryReadTMChan :: TMChan a -> STM (Maybe (Maybe a)) tryReadTMChan (TMChan closed chan) = do b <- readTVar closed if b then fmap Just <$> tryReadTChan chan else Just <$> tryReadTChan chan {- -- The above is lazier reading from @chan@ (and removes an extraneous isEmptyTChan when using the compatibility layer) than the clearer: tryReadTMChan (TMChan closed chan) = do b <- isEmptyTChan chan b' <- readTVar closed if b && b' then return Nothing else Just <$> tryReadTChan chan -- TODO: compare Core and benchmarks; is the loss of clarity worth it? -} -- | Get the next value from the @TMChan@ without removing it, -- retrying if the channel is empty. peekTMChan :: TMChan a -> STM (Maybe a) peekTMChan (TMChan closed chan) = do b <- readTVar closed if b then do b' <- isEmptyTChan chan if b' then return Nothing else Just <$> peekTChan chan else Just <$> peekTChan chan {- -- The above is lazier reading from @chan@ than the clearer: peekTMChan (TMChan closed chan) = do b <- isEmptyTChan chan b' <- readTVar closed if b && b' then return Nothing else Just <$> peekTChan chan -- TODO: compare Core and benchmarks; is the loss of clarity worth it? -} -- | A version of 'peekTMChan' which does not retry. Instead it -- returns @Just Nothing@ if the channel is open but no value is -- available; it still returns @Nothing@ if the channel is closed -- and empty. tryPeekTMChan :: TMChan a -> STM (Maybe (Maybe a)) tryPeekTMChan (TMChan closed chan) = do b <- readTVar closed if b then fmap Just <$> tryPeekTChan chan else Just <$> tryPeekTChan chan {- -- The above is lazier reading from @chan@ (and removes an extraneous isEmptyTChan when using the compatibility layer) than the clearer: tryPeekTMChan (TMChan closed chan) = do b <- isEmptyTChan chan b' <- readTVar closed if b && b' then return Nothing else Just <$> tryPeekTChan chan -- TODO: compare Core and benchmarks; is the loss of clarity worth it? -} -- | Write a value to a @TMChan@. If the channel is closed then the -- value is silently discarded. Use 'isClosedTMChan' to determine -- if the channel is closed before writing, as needed. writeTMChan :: TMChan a -> a -> STM () writeTMChan (TMChan closed chan) x = do b <- readTVar closed if b then return () -- discard silently else writeTChan chan x -- | Put a data item back onto a channel, where it will be the next -- item read. If the channel is closed then the value is silently -- discarded; you can use 'peekTMChan' to circumvent this in certain -- circumstances. unGetTMChan :: TMChan a -> a -> STM () unGetTMChan (TMChan closed chan) x = do b <- readTVar closed if b then return () -- discard silently else unGetTChan chan x -- | Closes the @TMChan@, preventing any further writes. closeTMChan :: TMChan a -> STM () closeTMChan (TMChan closed _chan) = writeTVar closed True -- | Returns @True@ if the supplied @TMChan@ has been closed. isClosedTMChan :: TMChan a -> STM Bool isClosedTMChan (TMChan closed _chan) = readTVar closed {- -- | Returns @True@ if the supplied @TMChan@ has been closed. isClosedTMChanIO :: TMChan a -> IO Bool isClosedTMChanIO (TMChan closed _chan) = readTVarIO closed -} -- | Returns @True@ if the supplied @TMChan@ is empty. isEmptyTMChan :: TMChan a -> STM Bool isEmptyTMChan (TMChan _closed chan) = isEmptyTChan chan ---------------------------------------------------------------- ----------------------------------------------------------- fin. stm-chans-3.0.0.9/src/Control/Concurrent/STM/TMQueue.hs0000644000000000000000000001555707346545000020641 0ustar0000000000000000{-# OPTIONS_GHC -Wall -fwarn-tabs #-} {-# LANGUAGE CPP, DeriveDataTypeable #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Safe #-} #endif ---------------------------------------------------------------- -- 2021.10.17 -- | -- Module : Control.Concurrent.STM.TMQueue -- Copyright : Copyright (c) 2011--2021 wren gayle romano -- License : BSD -- Maintainer : wren@cpan.org -- Stability : provisional -- Portability : non-portable (GHC STM, DeriveDataTypeable) -- -- A version of "Control.Concurrent.STM.TQueue" where the queue is -- closeable. This is similar to a @TQueue (Maybe a)@ with a -- monotonicity guarantee that once there's a @Nothing@ there will -- always be @Nothing@. -- -- /Since: 2.0.0/ ---------------------------------------------------------------- module Control.Concurrent.STM.TMQueue ( -- * The TMQueue type TMQueue() -- ** Creating TMQueues , newTMQueue , newTMQueueIO -- ** Reading from TMQueues , readTMQueue , tryReadTMQueue , peekTMQueue , tryPeekTMQueue -- ** Writing to TMQueues , writeTMQueue , unGetTMQueue -- ** Closing TMQueues , closeTMQueue -- ** Predicates , isClosedTMQueue , isEmptyTMQueue ) where import Data.Typeable (Typeable) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif import Control.Monad.STM (STM) import Control.Concurrent.STM.TVar import Control.Concurrent.STM.TQueue -- N.B., GHC only ---------------------------------------------------------------- -- | @TMQueue@ is an abstract type representing a closeable FIFO -- queue. data TMQueue a = TMQueue {-# UNPACK #-} !(TVar Bool) {-# UNPACK #-} !(TQueue a) deriving Typeable -- | Build and returns a new instance of @TMQueue@. newTMQueue :: STM (TMQueue a) newTMQueue = do closed <- newTVar False queue <- newTQueue return (TMQueue closed queue) -- | @IO@ version of 'newTMQueue'. This is useful for creating -- top-level @TMQueue@s using 'System.IO.Unsafe.unsafePerformIO', -- because using 'Control.Monad.STM.atomically' inside -- 'System.IO.Unsafe.unsafePerformIO' isn't possible. newTMQueueIO :: IO (TMQueue a) newTMQueueIO = do closed <- newTVarIO False queue <- newTQueueIO return (TMQueue closed queue) -- | Read the next value from the @TMQueue@, retrying if the queue -- is empty (and not closed). We return @Nothing@ immediately if -- the queue is closed and empty. readTMQueue :: TMQueue a -> STM (Maybe a) readTMQueue (TMQueue closed queue) = do b <- readTVar closed if b then tryReadTQueue queue else Just <$> readTQueue queue {- -- The above is lazier reading from @queue@, and slightly optimized, compared to the clearer: readTMQueue (TMQueue closed queue) = do b <- isEmptyTQueue queue b' <- readTVar closed if b && b' then return Nothing else Just <$> readTQueue queue -- TODO: compare Core and benchmarks; is the loss of clarity worth it? -} -- | A version of 'readTMQueue' which does not retry. Instead it -- returns @Just Nothing@ if the queue is open but no value is -- available; it still returns @Nothing@ if the queue is closed -- and empty. tryReadTMQueue :: TMQueue a -> STM (Maybe (Maybe a)) tryReadTMQueue (TMQueue closed queue) = do b <- readTVar closed if b then fmap Just <$> tryReadTQueue queue else Just <$> tryReadTQueue queue {- -- The above is lazier reading from @queue@ (and removes an extraneous isEmptyTQueue when using the compatibility layer) than the clearer: tryReadTMQueue (TMQueue closed queue) = do b <- isEmptyTQueue queue b' <- readTVar closed if b && b' then return Nothing else Just <$> tryReadTQueue queue -- TODO: compare Core and benchmarks; is the loss of clarity worth it? -} -- | Get the next value from the @TMQueue@ without removing it, -- retrying if the queue is empty. peekTMQueue :: TMQueue a -> STM (Maybe a) peekTMQueue (TMQueue closed queue) = do b <- readTVar closed if b then do b' <- isEmptyTQueue queue if b' then return Nothing else Just <$> peekTQueue queue else Just <$> peekTQueue queue {- -- The above is lazier reading from @queue@ than the clearer: peekTMQueue (TMQueue closed queue) = do b <- isEmptyTQueue queue b' <- readTVar closed if b && b' then return Nothing else Just <$> peekTQueue queue -- TODO: compare Core and benchmarks; is the loss of clarity worth it? -} -- | A version of 'peekTMQueue' which does not retry. Instead it -- returns @Just Nothing@ if the queue is open but no value is -- available; it still returns @Nothing@ if the queue is closed -- and empty. tryPeekTMQueue :: TMQueue a -> STM (Maybe (Maybe a)) tryPeekTMQueue (TMQueue closed queue) = do b <- readTVar closed if b then fmap Just <$> tryPeekTQueue queue else Just <$> tryPeekTQueue queue {- -- The above is lazier reading from @queue@ (and removes an extraneous isEmptyTQueue when using the compatibility layer) than the clearer: tryPeekTMQueue (TMQueue closed queue) = do b <- isEmptyTQueue queue b' <- readTVar closed if b && b' then return Nothing else Just <$> tryPeekTQueue queue -- TODO: compare Core and benchmarks; is the loss of clarity worth it? -} -- | Write a value to a @TMQueue@. If the queue is closed then the -- value is silently discarded. Use 'isClosedTMQueue' to determine -- if the queue is closed before writing, as needed. writeTMQueue :: TMQueue a -> a -> STM () writeTMQueue (TMQueue closed queue) x = do b <- readTVar closed if b then return () -- discard silently else writeTQueue queue x -- | Put a data item back onto a queue, where it will be the next -- item read. If the queue is closed then the value is silently -- discarded; you can use 'peekTMQueue' to circumvent this in certain -- circumstances. unGetTMQueue :: TMQueue a -> a -> STM () unGetTMQueue (TMQueue closed queue) x = do b <- readTVar closed if b then return () -- discard silently else unGetTQueue queue x -- | Closes the @TMQueue@, preventing any further writes. closeTMQueue :: TMQueue a -> STM () closeTMQueue (TMQueue closed _queue) = writeTVar closed True -- | Returns @True@ if the supplied @TMQueue@ has been closed. isClosedTMQueue :: TMQueue a -> STM Bool isClosedTMQueue (TMQueue closed _queue) = readTVar closed {- -- | Returns @True@ if the supplied @TMQueue@ has been closed. isClosedTMQueueIO :: TMQueue a -> IO Bool isClosedTMQueueIO (TMQueue closed _queue) = readTVarIO closed -} -- | Returns @True@ if the supplied @TMQueue@ is empty. isEmptyTMQueue :: TMQueue a -> STM Bool isEmptyTMQueue (TMQueue _closed queue) = isEmptyTQueue queue ---------------------------------------------------------------- ----------------------------------------------------------- fin. stm-chans-3.0.0.9/stm-chans.cabal0000644000000000000000000000503707346545000014635 0ustar0000000000000000Cabal-Version: 2.2 -- Cabal >=2.2 is required for: -- -- Since 2.1, the Cabal-Version must be the absolutely first thing -- in the file, even before comments. Also, no longer uses ">=". -- ---------------------------------------------------------------- -- wren gayle romano ~ 2023.03.19 ---------------------------------------------------------------- Name: stm-chans Version: 3.0.0.9 Build-Type: Simple Stability: provisional Homepage: https://wrengr.org/software/hackage.html Bug-Reports: https://github.com/wrengr/stm-chans/issues Author: wren gayle romano, Thomas DuBuisson Maintainer: wren@cpan.org Copyright: 2011–2023 wren romano -- Cabal-2.2 requires us to say "BSD-3-Clause" not "BSD3" License: BSD-3-Clause License-File: LICENSE Category: Concurrency Synopsis: Additional types of channels for STM. Description: Additional types of channels for STM. Extra-source-files: AUTHORS, README.md, CHANGELOG -- This used to be tested on 7.8.3 and 7.10.1, but we don't verify that by CI. -- Tested-With: GHC ==8.0.2, GHC ==8.2.2, GHC ==8.4.4, GHC ==8.6.5, GHC ==8.8.4, GHC ==8.10.3, GHC ==9.0.1, GHC ==9.2.4, GHC ==9.4.4, GHC ==9.6.1 ---------------------------------------------------------------- Source-Repository head Type: git Location: https://github.com/wrengr/stm-chans.git ---------------------------------------------------------------- Library Default-Language: Haskell2010 -- N.B., the following versions are required for: -- * stm >= 2.4: T{,B}Queue and newBroadcastTChan{,IO} -- * stm >= 2.3.0: fast tryReadTChan, peekTChan, tryPeekTChan, -- tryReadTMVar, modifyTVar, modifyTVar', swapTVar. -- * stm >= 2.1.2: fast readTVarIO. -- -- Not sure what the real minbound is for base... Build-Depends: base >= 4.1 && < 5 , stm >= 2.4 Hs-Source-Dirs: src Exposed-Modules: Control.Concurrent.STM.TBChan , Control.Concurrent.STM.TBMChan , Control.Concurrent.STM.TMChan , Control.Concurrent.STM.TBMQueue , Control.Concurrent.STM.TMQueue ---------------------------------------------------------------- ----------------------------------------------------------- fin.