[commit: stm] master: add cloneTChan (GHC Trac ticket #6157) (3122a9f)

Repository : ssh://darcs.haskell.org//srv/darcs/packages/stm

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/3122a9f7ab30f1eb0d70b50cabf29e6da2e20e5e

>---------------------------------------------------------------

commit 3122a9f7ab30f1eb0d70b50cabf29e6da2e20e5e
Author: Simon Marlow <[email protected]>
Date:   Mon Jun 11 12:21:43 2012 +0100

    add cloneTChan (GHC Trac ticket #6157)

>---------------------------------------------------------------

 Control/Concurrent/STM/TChan.hs |   11 ++++++++++-
 1 files changed, 10 insertions(+), 1 deletions(-)

diff --git a/Control/Concurrent/STM/TChan.hs b/Control/Concurrent/STM/TChan.hs
index dbc2eca..aea5176 100644
--- a/Control/Concurrent/STM/TChan.hs
+++ b/Control/Concurrent/STM/TChan.hs
@@ -33,7 +33,8 @@ module Control.Concurrent.STM.TChan (
 	writeTChan,
 	dupTChan,
 	unGetTChan,
-	isEmptyTChan
+        isEmptyTChan,
+        cloneTChan
 #endif
   ) where
 
@@ -143,4 +144,12 @@ isEmptyTChan (TChan read _write) = do
   case head of
     TNil -> return True
     TCons _ _ -> return False
+
+-- |Clone a 'TChan': similar to dupTChan, but the cloned channel starts with the
+-- same content available as the original channel.
+cloneTChan :: TChan a -> STM (TChan a)
+cloneTChan (TChan read write) = do
+  readpos <- readTVar read
+  new_read <- newTVar readpos
+  return (TChan new_read write)
 #endif