From fe361e3d2fb836685d2868de8af19f6df0029f02 Mon Sep 17 00:00:00 2001
From: Joey Adams <joeyadams3.14159@gmail.com>
Date: Sun, 29 Jul 2012 22:05:42 -0400
Subject: [PATCH 3/3] TBQueue: Add tryWriteTBQueue

---
 Control/Concurrent/STM/TBQueue.hs |   31 ++++++++++++++++++++++++-------
 1 files changed, 24 insertions(+), 7 deletions(-)

diff --git a/Control/Concurrent/STM/TBQueue.hs b/Control/Concurrent/STM/TBQueue.hs
index a3ff2da..a2069fb 100644
--- a/Control/Concurrent/STM/TBQueue.hs
+++ b/Control/Concurrent/STM/TBQueue.hs
@@ -36,6 +36,7 @@ module Control.Concurrent.STM.TBQueue (
 	peekTBQueue,
 	tryPeekTBQueue,
 	writeTBQueue,
+        tryWriteTBQueue,
         unGetTBQueue,
         isEmptyTBQueue,
   ) where
@@ -92,20 +93,36 @@ newTBQueueIO size = do
   wsize <- newTVarIO $! if size < 0 then 0 else size
   return (TBQueue rsize read wsize write)
 
--- |Write a value to a 'TBQueue'; blocks if the queue is full.
+-- |Write a value to a 'TBQueue'.  Block if the queue is full.
 writeTBQueue :: TBQueue a -> a -> STM ()
-writeTBQueue (TBQueue rsize _read wsize write) a = do
+writeTBQueue q a = do
+  ok <- tryWriteTBQueue q a
+  if ok
+    then return ()
+    else retry
+
+-- | A version of 'writeTBQueue' which does not 'retry'.  Instead, it returns
+-- @False@ if the queue is full.
+tryWriteTBQueue :: TBQueue a -> a -> STM Bool
+tryWriteTBQueue (TBQueue rsize _read wsize write) a = do
   w <- readTVar wsize
   if (w /= 0)
      then do writeTVar wsize $! w - 1
+             putW
      else do
           r <- readTVar rsize
           if (r /= 0)
              then do writeTVar rsize 0
                      writeTVar wsize $! r - 1
-             else retry
-  listend <- readTVar write
-  writeTVar write (a:listend)
+                     putW
+             else
+                -- NB: we did not modify the TBQueue before returning False.
+                return False
+  where
+    putW = do
+      listend <- readTVar write
+      writeTVar write (a:listend)
+      return True
 
 -- |Read the next value from the 'TBQueue'.
 readTBQueue :: TBQueue a -> STM a
@@ -128,7 +145,7 @@ readTBQueue (TBQueue rsize read _wsize write) = do
           writeTVar read zs
           return z
 
--- | A version of 'readTBQueue' which does not retry. Instead it
+-- | A version of 'readTBQueue' which does not 'retry'. Instead, it
 -- returns @Nothing@ if no value is available.
 tryReadTBQueue :: TBQueue a -> STM (Maybe a)
 tryReadTBQueue c = fmap Just (readTBQueue c) `orElse` return Nothing
@@ -141,7 +158,7 @@ peekTBQueue c = do
   unGetTBQueue c x
   return x
 
--- | A version of 'peekTBQueue' which does not retry. Instead it
+-- | A version of 'peekTBQueue' which does not 'retry'. Instead, it
 -- returns @Nothing@ if no value is available.
 tryPeekTBQueue :: TBQueue a -> STM (Maybe a)
 tryPeekTBQueue c = do
-- 
1.7.0.4