diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/io-sim.cabal b/io-sim.cabal --- a/io-sim.cabal +++ b/io-sim.cabal @@ -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, diff --git a/src/Control/Monad/IOSim/Types.hs b/src/Control/Monad/IOSim/Types.hs --- a/src/Control/Monad/IOSim/Types.hs +++ b/src/Control/Monad/IOSim/Types.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 ] diff --git a/test/Test/Control/Concurrent/Class/MonadMVar.hs b/test/Test/Control/Concurrent/Class/MonadMVar.hs new file mode 100644 --- /dev/null +++ b/test/Test/Control/Concurrent/Class/MonadMVar.hs @@ -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' diff --git a/test/Test/Control/Monad/Class/MonadMVar.hs b/test/Test/Control/Monad/Class/MonadMVar.hs deleted file mode 100644 --- a/test/Test/Control/Monad/Class/MonadMVar.hs +++ /dev/null @@ -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' diff --git a/test/Test/Control/Monad/IOSim.hs b/test/Test/Control/Monad/IOSim.hs --- a/test/Test/Control/Monad/IOSim.hs +++ b/test/Test/Control/Monad/IOSim.hs @@ -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