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

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

TBQueue: Add tryWriteTBQueue

  • Control/Concurrent/STM/TBQueue.hs

    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 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