packages feed

stm-chans (empty) → 1.0.0

raw patch · 8 files changed

+833/−0 lines, 8 filesdep +basedep +stmbuild-type:Customsetup-changed

Dependencies added: base, stm

Files

+ LICENSE view
@@ -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.+
+ Setup.hs view
@@ -0,0 +1,27 @@+#!/usr/bin/env runhaskell+-- Cf. <http://www.mail-archive.com/haskell-cafe@haskell.org/msg59984.html>+-- <http://www.haskell.org/pipermail/haskell-cafe/2008-December/051785.html>++{-# 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.
+ src/Control/Concurrent/STM/TBChan.hs view
@@ -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.
+ src/Control/Concurrent/STM/TBMChan.hs view
@@ -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.
+ src/Control/Concurrent/STM/TChan/Compat.hs view
@@ -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.
+ src/Control/Concurrent/STM/TMChan.hs view
@@ -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.
+ src/Control/Concurrent/STM/TVar/Compat.hs view
@@ -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.
+ stm-chans.cabal view
@@ -0,0 +1,42 @@+----------------------------------------------------------------+-- wren ng thornton <wren@community.haskell.org>    ~ 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.