Skip to content

WIP io-sim: flushTQueue does not maintain order #136

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Closed
wants to merge 2 commits into from
Closed
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 2 additions & 0 deletions io-classes/CHANGELOG.md
Original file line number Diff line number Diff line change
Expand Up @@ -8,6 +8,8 @@

### Non-breaking changes

* Fixed some module haddock typos.

## 1.3.1.0

### Non-breaking changes
Expand Down
2 changes: 1 addition & 1 deletion io-classes/src/Control/Concurrent/Class/MonadSTM/TQueue.hs
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
{-# LANGUAGE ExplicitNamespaces #-}

-- | This module corresponds to `Control.Concurrnet.STM.TVar` in "stm" package
-- | This module corresponds to `Control.Concurrent.STM.TQueue` in "stm" package
--
module Control.Concurrent.Class.MonadSTM.TQueue
( -- * MonadSTM
Expand Down
2 changes: 1 addition & 1 deletion io-classes/src/Control/Monad/Class/MonadSTM/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -48,7 +48,7 @@ module Control.Monad.Class.MonadSTM.Internal
, isEmptyTMVarDefault
, labelTMVarDefault
, traceTMVarDefault
-- ** Default 'TBQueue' implementation
-- ** Default 'TQueue' implementation
, TQueueDefault (..)
, newTQueueDefault
, writeTQueueDefault
Expand Down
1 change: 1 addition & 0 deletions io-sim/CHANGELOG.md
Original file line number Diff line number Diff line change
Expand Up @@ -9,6 +9,7 @@
### Non-breaking changes

* `Alternative` & `MonadPlus` instances for `IOSim`.
* Fixed `flushTQueue` implemetation.

## 1.3.1.0

Expand Down
2 changes: 1 addition & 1 deletion io-sim/io-sim.cabal
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
cabal-version: 3.0
name: io-sim
version: 1.3.1.0
version: 1.3.1.1
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Could you revert this, I figure out version changes when releasing to hackage.

synopsis: A pure simulator for monadic concurrency with STM.
description:
A pure simulator monad with support of concurency (base, async), stm,
Expand Down
5 changes: 4 additions & 1 deletion io-sim/src/Control/Monad/IOSim/STM.hs
Original file line number Diff line number Diff line change
Expand Up @@ -95,7 +95,10 @@ tryPeekTQueueDefault (TQueue queue) = do
[] -> Nothing

flushTQueueDefault :: MonadSTM m => TQueueDefault m a -> STM m [a]
flushTQueueDefault (TQueue queue) = uncurry (++) <$> readTVar queue
flushTQueueDefault (TQueue queue) = do
xs <- uncurry (++) <$> readTVar queue
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I think you need to reverse the tail, e.g.

Suggested change
xs <- uncurry (++) <$> readTVar queue
xs <- (\front tail -> front ++ reverse tail) <$> readTVar queue

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I know.. I was not trying to fix it yet, but get the other PR merged first.

writeTVar queue ([], [])
pure xs

unGetTQueueDefault :: MonadSTM m => TQueueDefault m a -> a -> STM m ()
unGetTQueueDefault (TQueue queue) a = do
Expand Down
33 changes: 33 additions & 0 deletions io-sim/test/Test/Control/Monad/IOSim.hs
Original file line number Diff line number Diff line change
Expand Up @@ -176,6 +176,12 @@ tests =
, testProperty "registerDelayCancellable (IO impl)"
prop_registerDelayCancellable_IO
]
, testGroup "MonadSTM"
[ testGroup "flushTQueue"
[ testProperty "empties the queue" prop_flushTQueueEmpties
, testProperty "maintains FIFO order" prop_flushTQueueOrder
]
]
]

--
Expand Down Expand Up @@ -1348,6 +1354,33 @@ prop_registerDelayCancellable_IO =
cancelTimeout
awaitTimeout

-- | Test that 'flushTQueue' empties the queue.
prop_flushTQueueEmpties :: Property
prop_flushTQueueEmpties =
ioProperty emptyQueueAfterFlush
.&&. runSimOrThrow emptyQueueAfterFlush

emptyQueueAfterFlush :: MonadSTM m => m Bool
emptyQueueAfterFlush = do
q <- newTQueueIO
atomically $ do
writeTQueue q (1 :: Int)
_ <- flushTQueue q
isEmptyTQueue q

-- | Test that 'flushTQueue' returns values in FIFO order.
prop_flushTQueueOrder :: [Int] -> Property
prop_flushTQueueOrder entries =
ioProperty (writeAndFlushQueue entries >>= \actual -> pure $ actual === entries)
.&&. runSimOrThrow (writeAndFlushQueue entries) === entries

writeAndFlushQueue :: MonadSTM m => [Int] -> m [Int]
writeAndFlushQueue entries =
atomically $ do
q <- newTQueue
forM_ entries $ writeTQueue q
flushTQueue q

--
-- Utils
--
Expand Down