Ticket #7104: 0003-TBQueue-Add-tryWriteTBQueue.patch

File 0003-TBQueue-Add-tryWriteTBQueue.patch, 2.8 KB (added by joeyadams, 3 years ago)

TBQueue: Add tryWriteTBQueue

  • Control/Concurrent/STM/TBQueue.hs

    From fe361e3d2fb836685d2868de8af19f6df0029f02 Mon Sep 17 00:00:00 2001
    From: Joey Adams <[email protected]>
    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 b module Control.Concurrent.STM.TBQueue ( 
    3636        peekTBQueue,
    3737        tryPeekTBQueue,
    3838        writeTBQueue,
     39        tryWriteTBQueue,
    3940        unGetTBQueue,
    4041        isEmptyTBQueue,
    4142  ) where
    newTBQueueIO size = do 
    9293  wsize <- newTVarIO $! if size < 0 then 0 else size
    9394  return (TBQueue rsize read wsize write)
    9495
    95 -- |Write a value to a 'TBQueue'; blocks if the queue is full.
     96-- |Write a value to a 'TBQueue'.  Block if the queue is full.
    9697writeTBQueue :: TBQueue a -> a -> STM ()
    97 writeTBQueue (TBQueue rsize _read wsize write) a = do
     98writeTBQueue q a = do
     99  ok <- tryWriteTBQueue q a
     100  if ok
     101    then return ()
     102    else retry
     103
     104-- | A version of 'writeTBQueue' which does not 'retry'.  Instead, it returns
     105-- @False@ if the queue is full.
     106tryWriteTBQueue :: TBQueue a -> a -> STM Bool
     107tryWriteTBQueue (TBQueue rsize _read wsize write) a = do
    98108  w <- readTVar wsize
    99109  if (w /= 0)
    100110     then do writeTVar wsize $! w - 1
     111             putW
    101112     else do
    102113          r <- readTVar rsize
    103114          if (r /= 0)
    104115             then do writeTVar rsize 0
    105116                     writeTVar wsize $! r - 1
    106              else retry
    107   listend <- readTVar write
    108   writeTVar write (a:listend)
     117                     putW
     118             else
     119                -- NB: we did not modify the TBQueue before returning False.
     120                return False
     121  where
     122    putW = do
     123      listend <- readTVar write
     124      writeTVar write (a:listend)
     125      return True
    109126
    110127-- |Read the next value from the 'TBQueue'.
    111128readTBQueue :: TBQueue a -> STM a
    readTBQueue (TBQueue rsize read _wsize write) = do 
    128145          writeTVar read zs
    129146          return z
    130147
    131 -- | A version of 'readTBQueue' which does not retry. Instead it
     148-- | A version of 'readTBQueue' which does not 'retry'. Instead, it
    132149-- returns @Nothing@ if no value is available.
    133150tryReadTBQueue :: TBQueue a -> STM (Maybe a)
    134151tryReadTBQueue c = fmap Just (readTBQueue c) `orElse` return Nothing
    peekTBQueue c = do 
    141158  unGetTBQueue c x
    142159  return x
    143160
    144 -- | A version of 'peekTBQueue' which does not retry. Instead it
     161-- | A version of 'peekTBQueue' which does not 'retry'. Instead, it
    145162-- returns @Nothing@ if no value is available.
    146163tryPeekTBQueue :: TBQueue a -> STM (Maybe a)
    147164tryPeekTBQueue c = do