io-sim 1.0.0.1 → 1.1.0.0
raw patch · 7 files changed
+369/−350 lines, 7 filesdep ~io-classesdep ~si-timersdep ~strict-stmPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: io-classes, si-timers, strict-stm
API changes (from Hackage documentation)
Files
- CHANGELOG.md +6/−0
- io-sim.cabal +6/−6
- src/Control/Monad/IOSim/Types.hs +3/−3
- test/Main.hs +2/−2
- test/Test/Control/Concurrent/Class/MonadMVar.hs +330/−0
- test/Test/Control/Monad/Class/MonadMVar.hs +0/−330
- test/Test/Control/Monad/IOSim.hs +22/−9
CHANGELOG.md view
@@ -1,5 +1,11 @@ # Revsion history of io-sim +## 1.1.0.0++### Non breaking changes++* `io-classes-1.1.0.0`+ ## 1.0.0.1 ### Non breaking changes
io-sim.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: io-sim-version: 1.0.0.1+version: 1.1.0.0 synopsis: A pure simulator for monadic concurrency with STM. description: A pure simulator monad with support of concurency (base, async), stm,@@ -77,14 +77,14 @@ ScopedTypeVariables, TypeFamilies build-depends: base >=4.9 && <4.19,- io-classes ^>=1.0,+ io-classes ^>=1.1, exceptions >=0.10, containers, nothunks, parallel, psqueues >=0.2 && <0.3,- strict-stm ^>=1.0,- si-timers ^>=1.0,+ strict-stm >=1.0 && <1.2,+ si-timers >=1.0 && <1.2, time >=1.9.1 && <1.13, quiet, QuickCheck,@@ -98,11 +98,11 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs- other-modules: Test.Control.Monad.STM+ other-modules: Test.Control.Concurrent.Class.MonadMVar+ Test.Control.Monad.STM Test.Control.Monad.Utils Test.Control.Monad.IOSim Test.Control.Monad.IOSimPOR- Test.Control.Monad.Class.MonadMVar default-language: Haskell2010 build-depends: base, array,
src/Control/Monad/IOSim/Types.hs view
@@ -75,6 +75,7 @@ import Control.Monad import Control.Monad.Fix (MonadFix (..)) +import Control.Concurrent.Class.MonadMVar import Control.Concurrent.Class.MonadSTM.Strict.TVar (StrictTVar) import qualified Control.Concurrent.Class.MonadSTM.Strict.TVar as StrictTVar import Control.Monad.Class.MonadAsync hiding (Async)@@ -82,7 +83,6 @@ import Control.Monad.Class.MonadEventlog import Control.Monad.Class.MonadFork hiding (ThreadId) import qualified Control.Monad.Class.MonadFork as MonadFork-import Control.Monad.Class.MonadMVar import Control.Monad.Class.MonadST import Control.Monad.Class.MonadSTM.Internal (MonadInspectSTM (..), MonadLabelledSTM (..), MonadSTM, MonadTraceSTM (..),@@ -942,7 +942,7 @@ [Labelled TVarId] -- ^ and created these (Maybe Effect) -- ^ effect performed (only for `IOSimPOR`) -- | aborted an STM transaction (by an exception)- -- + -- -- For /IOSimPOR/ it also holds performed effect. | EventTxAborted (Maybe Effect) -- | STM transaction blocked (due to `retry`)@@ -984,7 +984,7 @@ -- -- threadStatus --- + -- | event traced when `threadStatus` is executed | EventThreadStatus ThreadId -- ^ current thread ThreadId -- ^ queried thread
test/Main.hs view
@@ -2,7 +2,7 @@ import Test.Tasty -import qualified Test.Control.Monad.Class.MonadMVar (tests)+import qualified Test.Control.Concurrent.Class.MonadMVar (tests) import qualified Test.Control.Monad.IOSim (tests) import qualified Test.Control.Monad.IOSimPOR (tests) @@ -12,7 +12,7 @@ tests :: TestTree tests = testGroup "IO Sim"- [ Test.Control.Monad.Class.MonadMVar.tests+ [ Test.Control.Concurrent.Class.MonadMVar.tests , Test.Control.Monad.IOSim.tests , Test.Control.Monad.IOSimPOR.tests ]
+ test/Test/Control/Concurrent/Class/MonadMVar.hs view
@@ -0,0 +1,330 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++module Test.Control.Concurrent.Class.MonadMVar where++import Control.Concurrent.Class.MonadMVar+import Control.Monad.Class.MonadAsync+import Control.Monad.Class.MonadFork+import Control.Monad.Class.MonadTime.SI+import Control.Monad.Class.MonadTimer.SI+import Data.Bifoldable (bifoldMap)+import Data.Foldable (traverse_)+import Data.Functor (void, ($>))+import Data.Maybe (isNothing)+import Data.Monoid (All (..))++import Control.Monad.IOSim++import Test.QuickCheck+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck (testProperty)++tests :: TestTree+tests =+ testGroup "Control.Concurrent.Class.MonadMVar"+ [ testGroup "putMVar"+ [ testProperty "fairness (IOSim)" prop_putMVar_fairness_sim+ , testCase "blocks on a full MVar (IOSim)"+ unit_putMVar_blocks_on_full_sim+ , testCase "blocks on a full MVar (IO)"+ unit_putMVar_blocks_on_full_io+ ]+ , testGroup "takeMVar"+ [ testProperty "fairness (IOSim)" prop_takeMVar_fairness_sim+ , testCase "blocks on an empty MVar (IOSim)"+ unit_takeMVar_blocks_on_empty_sim+ , testCase "blocks on an empty MVar (IO)"+ unit_takeMVar_blocks_on_empty_io+ ]+ , testGroup "tryTakeMVar"+ [ testCase "does not block on an empty MVar (IOSim)"+ unit_tryTakeMVar_empty+ , testCase "does not block on a full MVar (IOSim)"+ unit_tryTakeMVar_full+ , testCase "return value on an empty MVar (IOSim)"+ unit_tryTakeMVar_return_empty_sim+ , testCase "return value on an full MVar (IOSim)"+ unit_tryTakeMVar_return_full_sim+ ]+ , testGroup "tryPutMVar"+ [ testCase "does not block on an empty MVar (IOSim)"+ unit_tryPutMVar_empty+ , testCase "does not block on a full MVar (IOSim)"+ unit_tryPutMVar_full+ , testCase "return value on an empty MVar (IOSim)"+ unit_tryPutMVar_return_empty_sim+ , testCase "return value on an full MVar (IOSim)"+ unit_tryPutMVar_return_full_sim+ ]+ , testGroup "isEmptyMVar"+ [ testCase "empty MVar is empty" unit_isEmptyMVar_empty_sim+ , testCase "full MVar is not empty" unit_isEmptyMVar_full_sim+ ]+ ]+++--+-- putMVar+--++-- | Check that 'takeMVar' is fair. This is test is only designed for 'IOSim'+-- as it relies on its thread scheduling and determinism.+--+putMVar_fairness_property+ :: forall m.+ ( MonadAsync m+ , MonadDelay m+ , MonadMVar m+ )+ => Int -- ^ number of threads+ -> m Bool+putMVar_fairness_property n = do+ v <- newEmptyMVar+ traverse_ (\a -> async $ do threadDelay 0.01+ putMVar v a)+ [1..n]+ threadDelay 0.02+ results <- sequence (replicate n (takeMVar v))+ return $ results == [1..n]++prop_putMVar_fairness_sim :: Positive (Small Int)+ -> Property+prop_putMVar_fairness_sim (Positive (Small n)) =+ let trace = runSimTrace (putMVar_fairness_property n)+ in counterexample (ppTrace trace)+ $ case traceResult False trace of+ Left err -> counterexample (show err) False+ Right a -> property a+++unit_putMVar_blocks_on_full+ :: ( MonadFork m+ , MonadDelay m+ , MonadMVar m+ )+ => m Bool+unit_putMVar_blocks_on_full = do+ start <- getMonotonicTime+ let delta = 0.01+ v <- newMVar ()+ _ <- forkIO $ threadDelay delta+ >> takeMVar v+ $> ()+ putMVar v ()+ end <- getMonotonicTime+ return (end `diffTime` start >= delta)++unit_putMVar_blocks_on_full_sim :: Assertion+unit_putMVar_blocks_on_full_sim = assertBool "did not block on an full MVar" $+ runSimOrThrow unit_putMVar_blocks_on_full++unit_putMVar_blocks_on_full_io :: Assertion+unit_putMVar_blocks_on_full_io =+ unit_putMVar_blocks_on_full >>= assertBool "did not block on an full MVar"+++--+-- takeMVar+--++-- | Check that 'takeMVar' is fair. This is test is only designed for 'IOSim'+-- as it relies on its thread scheduling and determinism.+--+takeMVar_fairness_property+ :: forall m.+ ( MonadAsync m+ , MonadDelay m+ , MonadMVar m+ , Eq (Async m Int)+ )+ => Int -- ^ number of threads+ -> m Property+takeMVar_fairness_property n = do+ v <- newEmptyMVar+ ts <- sequence $ replicate n (async $ takeMVar v)+ threadDelay 0.01+ traverse_ (putMVar v) [1..n]+ results <- waitAll ts+ return $ results === [1..n]++prop_takeMVar_fairness_sim :: Positive (Small Int)+ -> Property+prop_takeMVar_fairness_sim (Positive (Small n)) =+ runSimOrThrow (takeMVar_fairness_property n)+++unit_takeMVar_blocks_on_empty+ :: ( MonadFork m+ , MonadDelay m+ , MonadMVar m+ )+ => m Bool+unit_takeMVar_blocks_on_empty = do+ start <- getMonotonicTime+ let delta = 0.01+ v <- newEmptyMVar+ _ <- forkIO $ threadDelay delta+ >> putMVar v ()+ takeMVar v+ end <- getMonotonicTime+ return (end `diffTime` start >= delta)++unit_takeMVar_blocks_on_empty_sim :: Assertion+unit_takeMVar_blocks_on_empty_sim = assertBool "did not block on an empty MVar" $ runSimOrThrow unit_takeMVar_blocks_on_empty++unit_takeMVar_blocks_on_empty_io :: Assertion+unit_takeMVar_blocks_on_empty_io =+ unit_takeMVar_blocks_on_empty >>= assertBool "did not block on an empty MVar"++--+-- tryTakeMVar+--+++-- | Check that `IOSim`'s `tryTakeMVar` is non blocking.+--+tryTakeMVar_non_blocking_property+ :: Bool -> Bool+tryTakeMVar_non_blocking_property isEmpty =+ validateTrace $ runSimTrace $ do+ v <- if isEmpty+ then newEmptyMVar+ else newMVar ()+ void $ tryTakeMVar v+ where+ validateTrace :: SimTrace a -> Bool+ validateTrace = getAll . bifoldMap (const (All True))+ (\ev -> case seType ev of+ EventTxBlocked {} -> All False+ _ -> All True)++unit_tryTakeMVar_empty :: Assertion+unit_tryTakeMVar_empty = assertBool "blocked on an empty MVar" $+ tryTakeMVar_non_blocking_property False++unit_tryTakeMVar_full :: Assertion+unit_tryTakeMVar_full = assertBool "blocked on an empty MVar" $+ tryTakeMVar_non_blocking_property True+++tryTakeMVar_return_value+ :: MonadMVar m+ => Bool+ -> m Bool+tryTakeMVar_return_value isEmpty =+ do v <- if isEmpty+ then newEmptyMVar+ else newMVar ()+ a <- tryTakeMVar v+ return $ isNothing a == isEmpty++unit_tryTakeMVar_return_empty_sim :: Assertion+unit_tryTakeMVar_return_empty_sim =+ assertBool "tryTakeMVar on an empty should return result" $+ runSimOrThrow (tryTakeMVar_return_value True)++unit_tryTakeMVar_return_full_sim :: Assertion+unit_tryTakeMVar_return_full_sim =+ assertBool "tryTakeMVar on an full should return result" $+ runSimOrThrow (tryTakeMVar_return_value False)++--+-- tryPutMVar+--++-- | Check that `IOSim`'s `tryPutMVar` is non blocking.+--+tryPutMVar_non_blocking_property+ :: Bool -> Bool+tryPutMVar_non_blocking_property isEmpty =+ validateTrace $ runSimTrace $ do+ v <- if isEmpty+ then newEmptyMVar+ else newMVar ()+ void $ tryPutMVar v ()+ where+ validateTrace :: SimTrace a -> Bool+ validateTrace = getAll . bifoldMap (const (All True))+ (\ev -> case seType ev of+ EventTxBlocked {} -> All False+ _ -> All True)++unit_tryPutMVar_empty :: Assertion+unit_tryPutMVar_empty = assertBool "blocked on an empty MVar" $+ tryPutMVar_non_blocking_property False++unit_tryPutMVar_full :: Assertion+unit_tryPutMVar_full = assertBool "blocked on an empty MVar" $+ tryPutMVar_non_blocking_property True+++tryPutMVar_return_value+ :: forall m.+ MonadMVar m+ => Bool+ -> m Bool+tryPutMVar_return_value isEmpty = do+ v :: MVar m ()+ <- if isEmpty+ then newEmptyMVar+ else newMVar ()+ a <- tryPutMVar v ()+ return $ a == isEmpty++unit_tryPutMVar_return_empty_sim :: Assertion+unit_tryPutMVar_return_empty_sim =+ assertBool "tryPutMVar on an empty should return result" $+ runSimOrThrow (tryPutMVar_return_value True)++unit_tryPutMVar_return_full_sim :: Assertion+unit_tryPutMVar_return_full_sim =+ assertBool "tryPutMVar on an full should return result" $+ runSimOrThrow (tryPutMVar_return_value False)++--+-- isEmptyMVar+--++prop_isEmptyMVar+ :: forall m. MonadMVar m+ => Bool+ -> m Bool+prop_isEmptyMVar isEmpty = do+ v :: MVar m ()+ <- if isEmpty+ then newEmptyMVar+ else newMVar ()+ (isEmpty ==) <$> isEmptyMVar v++unit_isEmptyMVar_empty_sim :: Assertion+unit_isEmptyMVar_empty_sim =+ assertBool "empty mvar must be empty" $+ runSimOrThrow (prop_isEmptyMVar True)++unit_isEmptyMVar_full_sim :: Assertion+unit_isEmptyMVar_full_sim =+ assertBool "full mvar must not be empty" $+ runSimOrThrow (prop_isEmptyMVar False)++--+-- Utils+--++waitAll :: forall m.+ ( MonadAsync m+ , Eq (Async m Int)+ )+ => [Async m Int] -> m [Int]+waitAll = go []+ where+ go :: [Int] -> [Async m Int] -> m [Int]+ go as ts = do+ (t, a) <- waitAny ts+ let ts' = filter (/= t) ts+ case ts' of+ [] -> return (reverse (a : as))+ _ -> go (a : as) ts'
− test/Test/Control/Monad/Class/MonadMVar.hs
@@ -1,330 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}--module Test.Control.Monad.Class.MonadMVar where--import Control.Monad.Class.MonadAsync-import Control.Monad.Class.MonadFork-import Control.Monad.Class.MonadMVar-import Control.Monad.Class.MonadTime.SI-import Control.Monad.Class.MonadTimer.SI-import Data.Bifoldable (bifoldMap)-import Data.Foldable (traverse_)-import Data.Functor (void, ($>))-import Data.Maybe (isNothing)-import Data.Monoid (All (..))--import Control.Monad.IOSim--import Test.QuickCheck-import Test.Tasty-import Test.Tasty.HUnit-import Test.Tasty.QuickCheck (testProperty)--tests :: TestTree-tests =- testGroup "Control.Monad.Class.MonadMVar"- [ testGroup "putMVar"- [ testProperty "fairness (IOSim)" prop_putMVar_fairness_sim- , testCase "blocks on a full MVar (IOSim)"- unit_putMVar_blocks_on_full_sim- , testCase "blocks on a full MVar (IO)"- unit_putMVar_blocks_on_full_io- ]- , testGroup "takeMVar"- [ testProperty "fairness (IOSim)" prop_takeMVar_fairness_sim- , testCase "blocks on an empty MVar (IOSim)"- unit_takeMVar_blocks_on_empty_sim- , testCase "blocks on an empty MVar (IO)"- unit_takeMVar_blocks_on_empty_io- ]- , testGroup "tryTakeMVar"- [ testCase "does not block on an empty MVar (IOSim)"- unit_tryTakeMVar_empty- , testCase "does not block on a full MVar (IOSim)"- unit_tryTakeMVar_full- , testCase "return value on an empty MVar (IOSim)"- unit_tryTakeMVar_return_empty_sim- , testCase "return value on an full MVar (IOSim)"- unit_tryTakeMVar_return_full_sim- ]- , testGroup "tryPutMVar"- [ testCase "does not block on an empty MVar (IOSim)"- unit_tryPutMVar_empty- , testCase "does not block on a full MVar (IOSim)"- unit_tryPutMVar_full- , testCase "return value on an empty MVar (IOSim)"- unit_tryPutMVar_return_empty_sim- , testCase "return value on an full MVar (IOSim)"- unit_tryPutMVar_return_full_sim- ]- , testGroup "isEmptyMVar"- [ testCase "empty MVar is empty" unit_isEmptyMVar_empty_sim- , testCase "full MVar is not empty" unit_isEmptyMVar_full_sim- ]- ]-------- putMVar------- | Check that 'takeMVar' is fair. This is test is only designed for 'IOSim'--- as it relies on its thread scheduling and determinism.----putMVar_fairness_property- :: forall m.- ( MonadAsync m- , MonadDelay m- , MonadMVar m- )- => Int -- ^ number of threads- -> m Bool-putMVar_fairness_property n = do- v <- newEmptyMVar- traverse_ (\a -> async $ do threadDelay 0.01- putMVar v a)- [1..n]- threadDelay 0.02- results <- sequence (replicate n (takeMVar v))- return $ results == [1..n]--prop_putMVar_fairness_sim :: Positive (Small Int)- -> Property-prop_putMVar_fairness_sim (Positive (Small n)) =- let trace = runSimTrace (putMVar_fairness_property n)- in counterexample (ppTrace trace)- $ case traceResult False trace of- Left err -> counterexample (show err) False- Right a -> property a---unit_putMVar_blocks_on_full- :: ( MonadFork m- , MonadDelay m- , MonadMVar m- )- => m Bool-unit_putMVar_blocks_on_full = do- start <- getMonotonicTime- let delta = 0.01- v <- newMVar ()- _ <- forkIO $ threadDelay delta- >> takeMVar v- $> ()- putMVar v ()- end <- getMonotonicTime- return (end `diffTime` start >= delta)--unit_putMVar_blocks_on_full_sim :: Assertion-unit_putMVar_blocks_on_full_sim = assertBool "did not block on an full MVar" $- runSimOrThrow unit_putMVar_blocks_on_full--unit_putMVar_blocks_on_full_io :: Assertion-unit_putMVar_blocks_on_full_io =- unit_putMVar_blocks_on_full >>= assertBool "did not block on an full MVar"-------- takeMVar------- | Check that 'takeMVar' is fair. This is test is only designed for 'IOSim'--- as it relies on its thread scheduling and determinism.----takeMVar_fairness_property- :: forall m.- ( MonadAsync m- , MonadDelay m- , MonadMVar m- , Eq (Async m Int)- )- => Int -- ^ number of threads- -> m Property-takeMVar_fairness_property n = do- v <- newEmptyMVar- ts <- sequence $ replicate n (async $ takeMVar v)- threadDelay 0.01- traverse_ (putMVar v) [1..n]- results <- waitAll ts- return $ results === [1..n]--prop_takeMVar_fairness_sim :: Positive (Small Int)- -> Property-prop_takeMVar_fairness_sim (Positive (Small n)) =- runSimOrThrow (takeMVar_fairness_property n)---unit_takeMVar_blocks_on_empty- :: ( MonadFork m- , MonadDelay m- , MonadMVar m- )- => m Bool-unit_takeMVar_blocks_on_empty = do- start <- getMonotonicTime- let delta = 0.01- v <- newEmptyMVar- _ <- forkIO $ threadDelay delta- >> putMVar v ()- takeMVar v- end <- getMonotonicTime- return (end `diffTime` start >= delta)--unit_takeMVar_blocks_on_empty_sim :: Assertion-unit_takeMVar_blocks_on_empty_sim = assertBool "did not block on an empty MVar" $ runSimOrThrow unit_takeMVar_blocks_on_empty--unit_takeMVar_blocks_on_empty_io :: Assertion-unit_takeMVar_blocks_on_empty_io =- unit_takeMVar_blocks_on_empty >>= assertBool "did not block on an empty MVar"------- tryTakeMVar-------- | Check that `IOSim`'s `tryTakeMVar` is non blocking.----tryTakeMVar_non_blocking_property- :: Bool -> Bool-tryTakeMVar_non_blocking_property isEmpty =- validateTrace $ runSimTrace $ do- v <- if isEmpty- then newEmptyMVar- else newMVar ()- void $ tryTakeMVar v- where- validateTrace :: SimTrace a -> Bool- validateTrace = getAll . bifoldMap (const (All True))- (\ev -> case seType ev of- EventTxBlocked {} -> All False- _ -> All True)--unit_tryTakeMVar_empty :: Assertion-unit_tryTakeMVar_empty = assertBool "blocked on an empty MVar" $- tryTakeMVar_non_blocking_property False--unit_tryTakeMVar_full :: Assertion-unit_tryTakeMVar_full = assertBool "blocked on an empty MVar" $- tryTakeMVar_non_blocking_property True---tryTakeMVar_return_value- :: MonadMVar m- => Bool- -> m Bool-tryTakeMVar_return_value isEmpty =- do v <- if isEmpty- then newEmptyMVar- else newMVar ()- a <- tryTakeMVar v- return $ isNothing a == isEmpty--unit_tryTakeMVar_return_empty_sim :: Assertion-unit_tryTakeMVar_return_empty_sim =- assertBool "tryTakeMVar on an empty should return result" $- runSimOrThrow (tryTakeMVar_return_value True)--unit_tryTakeMVar_return_full_sim :: Assertion-unit_tryTakeMVar_return_full_sim =- assertBool "tryTakeMVar on an full should return result" $- runSimOrThrow (tryTakeMVar_return_value False)------- tryPutMVar------- | Check that `IOSim`'s `tryPutMVar` is non blocking.----tryPutMVar_non_blocking_property- :: Bool -> Bool-tryPutMVar_non_blocking_property isEmpty =- validateTrace $ runSimTrace $ do- v <- if isEmpty- then newEmptyMVar- else newMVar ()- void $ tryPutMVar v ()- where- validateTrace :: SimTrace a -> Bool- validateTrace = getAll . bifoldMap (const (All True))- (\ev -> case seType ev of- EventTxBlocked {} -> All False- _ -> All True)--unit_tryPutMVar_empty :: Assertion-unit_tryPutMVar_empty = assertBool "blocked on an empty MVar" $- tryPutMVar_non_blocking_property False--unit_tryPutMVar_full :: Assertion-unit_tryPutMVar_full = assertBool "blocked on an empty MVar" $- tryPutMVar_non_blocking_property True---tryPutMVar_return_value- :: forall m.- MonadMVar m- => Bool- -> m Bool-tryPutMVar_return_value isEmpty = do- v :: MVar m ()- <- if isEmpty- then newEmptyMVar- else newMVar ()- a <- tryPutMVar v ()- return $ a == isEmpty--unit_tryPutMVar_return_empty_sim :: Assertion-unit_tryPutMVar_return_empty_sim =- assertBool "tryPutMVar on an empty should return result" $- runSimOrThrow (tryPutMVar_return_value True)--unit_tryPutMVar_return_full_sim :: Assertion-unit_tryPutMVar_return_full_sim =- assertBool "tryPutMVar on an full should return result" $- runSimOrThrow (tryPutMVar_return_value False)------- isEmptyMVar-----prop_isEmptyMVar- :: forall m. MonadMVar m- => Bool- -> m Bool-prop_isEmptyMVar isEmpty = do- v :: MVar m ()- <- if isEmpty- then newEmptyMVar- else newMVar ()- (isEmpty ==) <$> isEmptyMVar v--unit_isEmptyMVar_empty_sim :: Assertion-unit_isEmptyMVar_empty_sim =- assertBool "empty mvar must be empty" $- runSimOrThrow (prop_isEmptyMVar True)--unit_isEmptyMVar_full_sim :: Assertion-unit_isEmptyMVar_full_sim =- assertBool "full mvar must not be empty" $- runSimOrThrow (prop_isEmptyMVar False)------- Utils-----waitAll :: forall m.- ( MonadAsync m- , Eq (Async m Int)- )- => [Async m Int] -> m [Int]-waitAll = go []- where- go :: [Int] -> [Async m Int] -> m [Int]- go as ts = do- (t, a) <- waitAny ts- let ts' = filter (/= t) ts- case ts' of- [] -> return (reverse (a : as))- _ -> go (a : as) ts'
test/Test/Control/Monad/IOSim.hs view
@@ -172,15 +172,9 @@ -- scheduler works the way it does. , testGroup "MonadTimerCancellable" [ testProperty "registerDelayCancellable (IOSim impl)"- (prop_registerDelayCancellable registerDelayCancellable)+ prop_registerDelayCancellable_IOSim , testProperty "registerDelayCancellable (IO impl)"- (prop_registerDelayCancellable $- defaultRegisterDelayCancellable- (newTimeout . microsecondsAsIntToDiffTime)- readTimeout- cancelTimeout- awaitTimeout- )+ prop_registerDelayCancellable_IO ] ] @@ -1302,7 +1296,7 @@ (DelayWithCancel delay mbCancel) = -- 'within' covers the case where `registerDelayCancellable` would not -- make progress awaiting for the timeout (a live lock).- within 1000 $+ within 50_000 $ -- 50ms let trace = runSimTrace sim in case traceResult True trace of Left err -> counterexample (ppTrace trace)@@ -1334,6 +1328,25 @@ | delay == cancelDelay -> (Just tv, tv == TimeoutFired || tv == TimeoutCancelled) | otherwise -> (Just tv, tv == TimeoutCancelled)++++-- | Both tests run in `IOSim`, they only differ with the implementation of+-- `registerDelayCancellable`+--+prop_registerDelayCancellable_IOSim, prop_registerDelayCancellable_IO+ :: DelayWithCancel -> Property++prop_registerDelayCancellable_IOSim =+ prop_registerDelayCancellable registerDelayCancellable++prop_registerDelayCancellable_IO =+ prop_registerDelayCancellable $+ defaultRegisterDelayCancellable+ (newTimeout . microsecondsAsIntToDiffTime)+ readTimeout+ cancelTimeout+ awaitTimeout -- -- Utils