diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,35 @@ +=== stm-chans license === + +Copyright (c) 2011, wren ng thornton. +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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,27 @@ +#!/usr/bin/env runhaskell +-- Cf. +-- + +{-# OPTIONS_GHC -Wall -fwarn-tabs -fno-warn-missing-signatures #-} +module Main (main) where +import Distribution.Simple +import Distribution.Simple.LocalBuildInfo (withPrograms) +import Distribution.Simple.Program (userSpecifyArgs) +---------------------------------------------------------------- + +-- | Define __HADDOCK__ when building documentation. +main :: IO () +main = defaultMainWithHooks + $ simpleUserHooks `modify_haddockHook` \oldHH pkg lbi hooks flags -> do + + -- Call the old haddockHook with a modified LocalBuildInfo + (\lbi' -> oldHH pkg lbi' hooks flags) + $ lbi `modify_withPrograms` \oldWP -> + userSpecifyArgs "haddock" ["--optghc=-D__HADDOCK__"] oldWP + + +modify_haddockHook hooks f = hooks { haddockHook = f (haddockHook hooks) } +modify_withPrograms lbi f = lbi { withPrograms = f (withPrograms lbi) } + +---------------------------------------------------------------- +----------------------------------------------------------- fin. diff --git a/src/Control/Concurrent/STM/TBChan.hs b/src/Control/Concurrent/STM/TBChan.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/STM/TBChan.hs @@ -0,0 +1,149 @@ +{-# OPTIONS_GHC -Wall -fwarn-tabs #-} +{-# LANGUAGE CPP, DeriveDataTypeable #-} +---------------------------------------------------------------- +-- 2011.04.03 +-- | +-- Module : Control.Concurrent.STM.TBChan +-- Copyright : Copyright (c) 2011 wren ng thornton +-- License : BSD +-- Maintainer : wren@community.haskell.org +-- Stability : experimental +-- Portability : non-portable (GHC STM, DeriveDataTypeable) +-- +-- A version of "Control.Concurrent.STM.TChan" where the queue is +-- bounded in length. +---------------------------------------------------------------- +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 + , unGetTBChan + -- ** Predicates + , isEmptyTBChan + , isFullTBChan + ) where + +import Data.Typeable (Typeable) +import Control.Monad.STM (STM, retry) +import Control.Concurrent.STM.TVar.Compat +import Control.Concurrent.STM.TChan.Compat -- N.B., GHC only + +-- N.B., we need a Custom cabal build-type for this to work. +#ifdef __HADDOCK__ +import Control.Monad.STM (atomically) +import System.IO.Unsafe (unsafePerformIO) +#endif +---------------------------------------------------------------- + +-- | @TBChan@ is an abstract type representing a bounded FIFO +-- channel. +data TBChan a = TBChan !(TVar Int) !(TChan a) + deriving (Typeable) + + +-- | 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 + limit <- newTVar n + chan <- newTChan + return (TBChan limit chan) + + +-- | @IO@ version of 'newTBChan'. This is useful for creating +-- top-level @TBChan@s using 'unsafePerformIO', because using +-- 'atomically' inside 'unsafePerformIO' isn't possible. +newTBChanIO :: Int -> IO (TBChan a) +newTBChanIO n = do + limit <- newTVarIO n + chan <- newTChanIO + return (TBChan limit chan) + + +-- | Read the next value from the @TBChan@, retrying if the channel +-- is empty. +readTBChan :: TBChan a -> STM a +readTBChan (TBChan limit chan) = do + x <- readTChan chan + modifyTVar' limit (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 limit chan) = do + mx <- tryReadTChan chan + case mx of + Nothing -> return Nothing + Just _x -> do + modifyTVar' limit (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 _limit 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 _limit chan) = + tryPeekTChan chan + + +-- | Write a value to a @TBChan@, retrying if the channel is full. +writeTBChan :: TBChan a -> a -> STM () +writeTBChan self@(TBChan limit chan) x = do + b <- isFullTBChan self + if b + then retry + else do + writeTChan chan x + modifyTVar' limit (subtract 1) + + +-- | 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 limit chan) x = do + unGetTChan chan x + modifyTVar' limit (subtract 1) + + +-- | 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 _limit 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. +isFullTBChan :: TBChan a -> STM Bool +isFullTBChan (TBChan limit _chan) = do + n <- readTVar limit + return $! n <= 0 + +---------------------------------------------------------------- +----------------------------------------------------------- fin. diff --git a/src/Control/Concurrent/STM/TBMChan.hs b/src/Control/Concurrent/STM/TBMChan.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/STM/TBMChan.hs @@ -0,0 +1,204 @@ +{-# OPTIONS_GHC -Wall -fwarn-tabs #-} +{-# LANGUAGE CPP, DeriveDataTypeable #-} +---------------------------------------------------------------- +-- 2011.04.03 +-- | +-- Module : Control.Concurrent.STM.TBMChan +-- Copyright : Copyright (c) 2011 wren ng thornton +-- License : BSD +-- Maintainer : wren@community.haskell.org +-- Stability : experimental +-- 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". +---------------------------------------------------------------- +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 + , unGetTBMChan + -- ** Closing TBMChans + , closeTBMChan + -- ** Predicates + , isClosedTBMChan + , isEmptyTBMChan + , isFullTBMChan + ) where + +import Data.Typeable (Typeable) +import Control.Applicative ((<$>)) +import Control.Monad.STM (STM, retry) +import Control.Concurrent.STM.TVar.Compat +import Control.Concurrent.STM.TChan.Compat -- N.B., GHC only + +-- N.B., we need a Custom cabal build-type for this to work. +#ifdef __HADDOCK__ +import Control.Monad.STM (atomically) +import System.IO.Unsafe (unsafePerformIO) +#endif +---------------------------------------------------------------- + +-- | @TBMChan@ is an abstract type representing a bounded closeable +-- FIFO channel. +data TBMChan a = TBMChan !(TVar Bool) !(TVar Int) !(TChan a) + deriving Typeable + + +-- | 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 + limit <- newTVar n + chan <- newTChan + return (TBMChan closed limit chan) + + +-- | @IO@ version of 'newTBMChan'. This is useful for creating +-- top-level @TBMChan@s using 'unsafePerformIO', because using +-- 'atomically' inside 'unsafePerformIO' isn't possible. +newTBMChanIO :: Int -> IO (TBMChan a) +newTBMChanIO n = do + closed <- newTVarIO False + limit <- newTVarIO n + chan <- newTChanIO + return (TBMChan closed limit 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 limit chan) = do + b <- isEmptyTChan chan + b' <- readTVar closed + if b && b' + then return Nothing + else do + x <- readTChan chan + modifyTVar' limit (1 +) + return (Just x) + + +-- | 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 limit chan) = do + b <- isEmptyTChan chan + b' <- readTVar closed + if b && b' + then return Nothing + else do + mx <- tryReadTChan chan + case mx of + Nothing -> return (Just Nothing) + Just _x -> do + modifyTVar' limit (1 +) + return (Just mx) + + +-- | 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 _limit chan) = do + b <- isEmptyTChan chan + b' <- readTVar closed + if b && b' + then return Nothing + else Just <$> peekTChan chan + + +-- | 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 _limit chan) = do + b <- isEmptyTChan chan + b' <- readTVar closed + if b && b' + then return Nothing + else Just <$> tryPeekTChan chan + + +-- | 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 limit chan) x = do + b <- readTVar closed + if b + then return () -- Discard silently + else do + b' <- isFullTBMChan self + if b' + then retry + else do + writeTChan chan x + modifyTVar' limit (subtract 1) + + +-- | 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 limit chan) x = do + b <- readTVar closed + if b + then return () -- Discard silently + else do + unGetTChan chan x + modifyTVar' limit (subtract 1) + + +-- | Closes the @TBMChan@, preventing any further writes. +closeTBMChan :: TBMChan a -> STM () +closeTBMChan (TBMChan closed _limit _chan) = + writeTVar closed True + + +-- | Returns @True@ if the supplied @TBMChan@ has been closed. +isClosedTBMChan :: TBMChan a -> STM Bool +isClosedTBMChan (TBMChan closed _limit _chan) = + readTVar 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 _limit 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. +isFullTBMChan :: TBMChan a -> STM Bool +isFullTBMChan (TBMChan _closed limit _chan) = do + n <- readTVar limit + return $! n <= 0 + +---------------------------------------------------------------- +----------------------------------------------------------- fin. diff --git a/src/Control/Concurrent/STM/TChan/Compat.hs b/src/Control/Concurrent/STM/TChan/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/STM/TChan/Compat.hs @@ -0,0 +1,99 @@ +{-# OPTIONS_GHC -Wall -fwarn-tabs #-} +{-# LANGUAGE CPP #-} +---------------------------------------------------------------- +-- 2011.04.03 +-- | +-- Module : Control.Concurrent.STM.TChan.Compat +-- Copyright : Copyright (c) 2011 wren ng thornton +-- License : BSD +-- Maintainer : wren@community.haskell.org +-- Stability : experimental +-- Portability : non-portable (GHC STM, CPP) +-- +-- Compatibility layer for older versions of the @stm@ library. +-- Namely, we define 'tryReadTChan', 'peekTChan', and 'tryPeekTChan' +-- which @stm-X.X.X@ lacks. These implementations are less efficient +-- than the package versions due to the 'TChan' type being abstract. +-- However, this module uses Cabal-style CPP macros in order to use +-- the package versions when available. +---------------------------------------------------------------- +module Control.Concurrent.STM.TChan.Compat + ( + -- * The TChan type + TChan + -- ** Creating TChans + , newTChan -- :: STM (TChan a) + , newTChanIO -- :: IO (TChan a) + , dupTChan -- :: TChan a -> STM (TChan a) + -- ** Reading from TChans + , readTChan -- :: TChan a -> STM a + , tryReadTChan -- :: TChan a -> STM (Maybe a) + , peekTChan -- :: TChan a -> STM a + , tryPeekTChan -- :: TChan a -> STM (Maybe a) + -- ** Writing to TChans + , unGetTChan -- :: TChan a -> a -> STM () + , writeTChan -- :: TChan a -> a -> STM () + -- ** Predicates + , isEmptyTChan -- :: TChan a -> STM Bool + ) where + +import Control.Concurrent.STM.TChan -- N.B., GHC only + +-- BUG: What version will these really be added? +#if ! (MIN_VERSION_stm(9,0,0)) +import Control.Applicative ((<$>)) +import Control.Monad.STM (STM) + +---------------------------------------------------------------- + +-- | A version of 'readTChan' which does not retry. Instead it +-- returns @Nothing@ if no value is available. +tryReadTChan :: TChan a -> STM (Maybe a) +tryReadTChan chan = do + b <- isEmptyTChan chan + if b then return Nothing else Just <$> readTChan chan +{- -- Optimized implementation for when patching @stm@ +tryReadTChan (TChan read _write) = do + hd <- readTVar =<< readTVar read + case hd of + TNil -> return Nothing + TCons a tl -> do + writeTVar read tl + return (Just a) +-} + + +-- | Get the next value from the @TChan@ without removing it, +-- retrying if the channel is empty. +peekTChan :: TChan a -> STM a +peekTChan chan = do + x <- readTChan chan + unGetTChan chan x + return x +{- -- Optimized implementation for when patching @stm@ +peekTChan (TChan read _write) = do + hd <- readTVar =<< readTVar read + case hd of + TNil -> retry + TCons a _ -> return a +-} + + +-- | A version of 'peekTChan' which does not retry. Instead it +-- returns @Nothing@ if no value is available. +tryPeekTChan :: TChan a -> STM (Maybe a) +tryPeekTChan chan = do + b <- isEmptyTChan chan + if b then return Nothing else Just <$> peekTChan chan +{- -- Optimized implementation for when patching @stm@ +tryPeekTChan (TChan read _write) = do + hd <- readTVar =<< readTVar read + case hd of + TNil -> return Nothing + TCons a _ -> return (Just a) +-} + +#endif + +---------------------------------------------------------------- +----------------------------------------------------------- fin. diff --git a/src/Control/Concurrent/STM/TMChan.hs b/src/Control/Concurrent/STM/TMChan.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/STM/TMChan.hs @@ -0,0 +1,180 @@ +{-# OPTIONS_GHC -Wall -fwarn-tabs #-} +{-# LANGUAGE CPP, DeriveDataTypeable #-} +---------------------------------------------------------------- +-- 2011.04.03 +-- | +-- Module : Control.Concurrent.STM.TMChan +-- Copyright : Copyright (c) 2011 wren ng thornton +-- License : BSD +-- Maintainer : wren@community.haskell.org +-- Stability : experimental +-- 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 + -- ** Reading from TMChans + , readTMChan + , tryReadTMChan + , peekTMChan + , tryPeekTMChan + -- ** Writing to TMChans + , writeTMChan + , unGetTMChan + -- ** Closing TMChans + , closeTMChan + -- ** Predicates + , isClosedTMChan + , isEmptyTMChan + ) where + +import Data.Typeable (Typeable) +import Control.Applicative ((<$>)) +import Control.Monad.STM (STM) +import Control.Concurrent.STM.TVar.Compat +import Control.Concurrent.STM.TChan.Compat -- N.B., GHC only + +-- N.B., we need a Custom cabal build-type for this to work. +#ifdef __HADDOCK__ +import Control.Monad.STM (atomically) +import System.IO.Unsafe (unsafePerformIO) +#endif +---------------------------------------------------------------- + +-- | @TMChan@ is an abstract type representing a closeable FIFO +-- channel. +data TMChan a = TMChan !(TVar Bool) !(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 'unsafePerformIO', because using +-- 'atomically' inside 'unsafePerformIO' isn't possible. +newTMChanIO :: IO (TMChan a) +newTMChanIO = do + closed <- newTVarIO False + chan <- newTChanIO + 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 <- isEmptyTChan chan + b' <- readTVar closed + if b && b' + then return Nothing + else Just <$> readTChan chan + + +-- | 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 <- isEmptyTChan chan + b' <- readTVar closed + if b && b' + then return Nothing + else Just <$> tryReadTChan chan + + +-- | 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 <- isEmptyTChan chan + b' <- readTVar closed + if b && b' + then return Nothing + else Just <$> peekTChan chan + + +-- | 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 <- isEmptyTChan chan + b' <- readTVar closed + if b && b' + then return Nothing + else Just <$> tryPeekTChan chan + + +-- | Write a value to a @TMChan@, retrying if the channel is full. +-- 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@ is empty. +isEmptyTMChan :: TMChan a -> STM Bool +isEmptyTMChan (TMChan _closed chan) = + isEmptyTChan chan + +---------------------------------------------------------------- +----------------------------------------------------------- fin. diff --git a/src/Control/Concurrent/STM/TVar/Compat.hs b/src/Control/Concurrent/STM/TVar/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/STM/TVar/Compat.hs @@ -0,0 +1,97 @@ +{-# OPTIONS_GHC -Wall -fwarn-tabs #-} +{-# LANGUAGE CPP #-} +---------------------------------------------------------------- +-- 2011.04.03 +-- | +-- Module : Control.Concurrent.STM.TVar.Compat +-- Copyright : Copyright (c) 2011 wren ng thornton +-- License : BSD +-- Maintainer : wren@community.haskell.org +-- Stability : experimental +-- Portability : non-portable (STM, CPP) +-- +-- Compatibility layer for older versions of the @stm@ library. +-- Namely, we define 'readTVarIO' which @stm-2.1.1@ lacks; and we +-- define 'modifyTVar', 'modifyTVar'', and 'swapTVar' which @stm-X.X.X@ +-- lacks. This module uses Cabal-style CPP macros in order to use +-- the package versions when available. +---------------------------------------------------------------- +module Control.Concurrent.STM.TVar.Compat + ( + -- * The TVar type + TVar() + -- ** Creating TVars + , newTVar -- :: a -> STM (TVar a) + , newTVarIO -- :: a -> IO (TVar a) + -- ** Reading from TVars + , readTVar -- :: TVar a -> STM a + , readTVarIO -- :: TVar a -> IO a + -- ** Writing to TVars + , writeTVar -- :: TVar a -> a -> STM () + , modifyTVar -- :: TVar a -> (a -> a) -> STM () + , modifyTVar' -- :: TVar a -> (a -> a) -> STM () + , swapTVar -- :: TVar a -> a -> STM a + -- ** Other capabilities + , registerDelay -- :: Int -> IO (TVar Bool) + ) where + +import Control.Concurrent.STM.TVar + +#if ! (MIN_VERSION_stm(2,1,2)) +import Control.Concurrent.STM (atomically) +#endif + +-- BUG: What version will these really be added? +#if ! (MIN_VERSION_stm(9,0,0)) +import Control.Concurrent.STM (STM) +#endif +---------------------------------------------------------------- + +#if ! (MIN_VERSION_stm(2,1,2)) +-- | Return the current value stored in a TVar. This is equivalent to +-- +-- > readTVarIO = atomically . readTVar +-- +-- but works much faster (on @stm >= 2.1.2@), because it doesn't +-- perform a complete transaction, it just reads the current value +-- of the TVar. +readTVarIO :: TVar a -> IO a +readTVarIO = atomically . readTVar +{-# INLINE readTVarIO #-} +#endif + + +-- BUG: What version will these really be added? +#if ! (MIN_VERSION_stm(9,0,0)) + +-- Like 'modifyIORef' but for @TVar@. +-- | Mutate the contents of a @TVar@. /N.B./, this version is +-- non-strict. +modifyTVar :: TVar a -> (a -> a) -> STM () +modifyTVar var f = do + x <- readTVar var + writeTVar var (f x) +{-# INLINE modifyTVar #-} + + +-- | Strict version of 'modifyTVar'. +modifyTVar' :: TVar a -> (a -> a) -> STM () +modifyTVar' var f = do + x <- readTVar var + writeTVar var $! f x +{-# INLINE modifyTVar' #-} + + +-- Like 'swapTMVar' but for @TVar@. +-- | Swap the contents of a @TVar@ for a new value. +swapTVar :: TVar a -> a -> STM a +swapTVar var new = do + old <- readTVar var + writeTVar var new + return old +{-# INLINE swapTVar #-} + +#endif + +---------------------------------------------------------------- +----------------------------------------------------------- fin. diff --git a/stm-chans.cabal b/stm-chans.cabal new file mode 100644 --- /dev/null +++ b/stm-chans.cabal @@ -0,0 +1,42 @@ +---------------------------------------------------------------- +-- wren ng thornton ~ 2011.04.03 +---------------------------------------------------------------- + +Name: stm-chans +Version: 1.0.0 +-- Source-Repository requires version 1.6 +Cabal-Version: >= 1.6 +-- We need a custom build in order to define __HADDOCK__ +Build-Type: Custom +Stability: experimental +Copyright: Copyright (c) 2011 wren ng thornton +License: BSD3 +License-File: LICENSE +Author: wren ng thornton +Maintainer: wren@community.haskell.org +Homepage: http://code.haskell.org/~wren/ +Category: System +Synopsis: Additional types of channels for STM. +Description: Additional types of channels for STM. + +Tested-With: GHC == 6.12.1, GHC == 6.12.3 +Source-Repository head + Type: darcs + Location: http://community.haskell.org/~wren/stm-chans + +---------------------------------------------------------------- +Library + -- Not sure what the real minbounds are for base and stm... + -- + -- N.B., stm >= 2.1.2 is required for fast readTVarIO + Build-Depends: base >= 4.1 && < 5, stm >= 2.1.1 + + Hs-Source-Dirs: src + Exposed-Modules: Control.Concurrent.STM.TBChan + , Control.Concurrent.STM.TBMChan + , Control.Concurrent.STM.TMChan + , Control.Concurrent.STM.TChan.Compat + , Control.Concurrent.STM.TVar.Compat + +---------------------------------------------------------------- +----------------------------------------------------------- fin.