diff --git a/io-sim/CHANGELOG.md b/io-sim/CHANGELOG.md index ae63d855..6a0e2b54 100644 --- a/io-sim/CHANGELOG.md +++ b/io-sim/CHANGELOG.md @@ -14,6 +14,7 @@ the value to other waiting threads. - Faster handling of timeouts and timers by using a more efficient internal representation. +- Fixed `tryReadTBQueue` when returning `Nothing`. ## 1.6.0.0 diff --git a/io-sim/src/Control/Monad/IOSim/STM.hs b/io-sim/src/Control/Monad/IOSim/STM.hs index b1717d75..8ef492dd 100644 --- a/io-sim/src/Control/Monad/IOSim/STM.hs +++ b/io-sim/src/Control/Monad/IOSim/STM.hs @@ -149,9 +149,7 @@ tryReadTBQueueDefault (TBQueue queue _size) = do return (Just x) [] -> case reverse ys of - [] -> do - writeTVar queue $! (xs, r', ys, w) - return Nothing + [] -> return Nothing -- NB. lazy: we want the transaction to be -- short, otherwise it will conflict diff --git a/io-sim/test/Test/Control/Monad/IOSim.hs b/io-sim/test/Test/Control/Monad/IOSim.hs index 3df53427..63a42437 100644 --- a/io-sim/test/Test/Control/Monad/IOSim.hs +++ b/io-sim/test/Test/Control/Monad/IOSim.hs @@ -192,6 +192,10 @@ tests = , testProperty "maintains FIFO order IO" prop_flushTBQueueOrder_IO , testProperty "maintains FIFO order IOSim" prop_flushTBQueueOrder_IOSim ] + , testGroup "tryReadTBQueue" + [ testProperty "works correctly when the queue is empty IO" prop_tryReadEmptyTBQueue_IO + , testProperty "works correctly when the queue is empty IOSim" prop_tryReadEmptyTBQueue_IOSim + ] ] ] @@ -1464,6 +1468,24 @@ writeAndFlushTBQueue entries = forM_ entries $ writeTBQueue q flushTBQueue q +prop_tryReadEmptyTBQueue_IO :: Bool -> Property +prop_tryReadEmptyTBQueue_IO sndRead = + ioProperty $ tryReadEmptyTBQueue sndRead + +prop_tryReadEmptyTBQueue_IOSim :: Bool -> Property +prop_tryReadEmptyTBQueue_IOSim sndRead = + runSimOrThrow $ tryReadEmptyTBQueue sndRead + +tryReadEmptyTBQueue :: MonadSTM m => Bool -> m Property +tryReadEmptyTBQueue sndRead = atomically $ do + q <- newTBQueue 10 + _ <- tryReadTBQueue q + writeTBQueue q () + when sndRead $ void $ tryReadTBQueue q + l <- lengthTBQueue q + + pure $ l === if sndRead then 0 else 1 + -- -- Utils --