diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,16 @@ # Revision history of io-sim +## 1.10.1.0 + +### Non-breaking changes + +* Added `IOSimPOR` `QuickCheck` combinators: + * `monadicIOSimPOR_` + * `monadicIOSimPOR` + * `runIOSimPORGen` +* Support ghc-9.14 +* Support QuickCheck-2.18.0.0 + ## 1.10.0.0 ### Breaking changes @@ -23,7 +34,9 @@ `EventLogEvaluationError`. * Added `Data.List.Trace.last` * Although `IOSim` and `IOSimPOR` are pure we use `evaluate` in a few places, - non of them now catch asynchrounous exceptions. + none of them now catch asynchronous exceptions. +* Added `IOSimPOR` QuickCheck monadic combinators: + `monadicIOSimPOR`, `monadicIOSimPOR_` and `runIOSimPORGen`. ## 1.9.1.0 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.4 name: io-sim -version: 1.10.0.0 +version: 1.10.1.0 synopsis: A pure simulator for monadic concurrency with STM. description: A pure simulator monad with support of concurrency (base & async style), stm, @@ -19,7 +19,7 @@ build-type: Simple extra-doc-files: CHANGELOG.md README.md bug-reports: https://github.com/input-output-hk/io-sim/issues -tested-with: GHC == { 9.6, 9.8, 9.10, 9.12 } +tested-with: GHC == { 9.6, 9.8, 9.10, 9.12, 9.14 } flag asserts description: Enable assertions @@ -64,9 +64,9 @@ default-extensions: LambdaCase if impl(ghc < 9.4) default-extensions: GADTs - build-depends: base >=4.16 && <4.22, + build-depends: base >=4.16 && <4.23, io-classes:{io-classes,strict-stm,si-timers} - ^>=1.9 || ^>=1.10, + ^>=1.10, exceptions >=0.10, containers, deepseq, @@ -112,6 +112,8 @@ -rtsopts if impl(ghc >= 9.8) ghc-options: -Wno-x-partial + if impl(ghc >= 9.14) + ghc-options: -Wno-incomplete-record-selectors benchmark bench import: warnings diff --git a/src/Control/Monad/IOSim.hs b/src/Control/Monad/IOSim.hs --- a/src/Control/Monad/IOSim.hs +++ b/src/Control/Monad/IOSim.hs @@ -18,6 +18,9 @@ , monadicIOSim , runIOSimGen -- ** Explore races using /IOSimPOR/ + , monadicIOSimPOR_ + , monadicIOSimPOR + , runIOSimPORGen -- $iosimpor , exploreSimTrace , controlSimTrace @@ -801,3 +804,77 @@ Capture eval <- capture let trace = runSimTrace (eval sim) return (f trace) + +-- | Like , +-- but evaluates generated simulations using 'exploreSimTrace'. +-- +-- The callback receives the previously passing trace (if any) and the current +-- trace being checked. +-- +-- @since 1.10.0.0 +-- +runIOSimPORGen :: Testable test + => (ExplorationOptions -> ExplorationOptions) + -> (Maybe (SimTrace a) -> SimTrace a -> test) + -> (forall s. Gen (IOSim s a)) + -> Gen Property +runIOSimPORGen optsf k sim = do + Capture eval <- capture + pure $ exploreSimTrace optsf (eval sim) k + +-- | A /IOSimPOR/ variant of 'monadicIOSim_', which: +-- +-- * explores alternative schedules using 'exploreSimTrace'; +-- * allows to run in monad stacks build on top of `IOSim`; +-- * gives more control how to attach debugging information to failed +-- tests. +-- +-- Note, to use this combinator your monad needs to be defined as: +-- +-- > newtype M s a = M { runM :: ReaderT State (IOSim s) a } +-- +-- It's important that `M s` is a monad. For such a monad you'll need to +-- provide a natural transformation: +-- @ +-- -- the state could also be created as an `IOSim` computation. +-- nat :: forall s a. State -> M s a -> 'IOSim' s a +-- nat state m = runStateT (runM m) state +-- @ +-- +-- @since 1.10.0.0 +-- +monadicIOSimPOR :: (Testable a, forall s. Monad (m s)) + => (ExplorationOptions -> ExplorationOptions) + -> (Maybe (SimTrace Property) -> SimTrace Property -> Property) + -> (forall s a. m s a -> IOSim s a) + -> (forall s. PropertyM (m s) a) + -> Property +monadicIOSimPOR optsf f tr sim = + property (runIOSimPORGen optsf f (tr <$> monadic' sim)) + +-- | Like , +-- but using /IOSimPOR/ schedule exploration. +-- +-- Note: it calls `traceResult` in non-strict mode, e.g. leaked threads do not +-- cause failures. +-- +-- > testProperty "example" $ +-- > monadicIOSimPOR_ $ do +-- > x <- run (pure (1 :: Int)) +-- > assert (x == 1) +-- +-- @since 1.10.0.0 +-- +monadicIOSimPOR_ :: Testable a + => (forall s. PropertyM (IOSim s) a) + -> Property +monadicIOSimPOR_ sim = + monadicIOSimPOR + id + (\_ tr -> case traceResult False tr of + Left e -> counterexample (show e) False + Right p -> p) + id + sim 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 @@ -846,7 +846,6 @@ deriving Generic deriving Show via Quiet SimEvent - -- | Pretty print a 'SimEvent'. -- ppSimEvent :: Int -- ^ width of the time 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 @@ -56,9 +56,9 @@ tests = testGroup "IOSim" [ testProperty "read/write graph (IO)" prop_stm_graph_io - , testProperty "read/write graph (IOSim)" (withMaxSuccess 1000 prop_stm_graph_sim) + , testProperty "read/write graph (IOSim)" (withNumTests 1000 prop_stm_graph_sim) , testGroup "timeouts" - [ testProperty "IOSim" (withMaxSuccess 1000 prop_timers_ST) + [ testProperty "IOSim" (withNumTests 1000 prop_timers_ST) -- fails since we just use `threadDelay` to schedule timers in `IO`. , testProperty "IO" (expectFailure prop_timers_IO) , testProperty "IOSim: no deadlock" prop_timeout_no_deadlock_Sim @@ -83,8 +83,8 @@ [ testProperty "timeout: discardAfter" unit_discardAfter , testProperty "timeout: within" unit_within ] - , testProperty "threadId order (IOSim)" (withMaxSuccess 1000 prop_threadId_order_order_Sim) - , testProperty "forkIO order (IOSim)" (withMaxSuccess 1000 prop_fork_order_ST) + , testProperty "threadId order (IOSim)" (withNumTests 1000 prop_threadId_order_order_Sim) + , testProperty "forkIO order (IOSim)" (withNumTests 1000 prop_fork_order_ST) , testProperty "order (IO)" (expectFailure prop_fork_order_IO) , testProperty "STM wakeup order" prop_wakeup_order_ST , testGroup "throw/catch unit tests" diff --git a/test/Test/Control/Monad/IOSimPOR.hs b/test/Test/Control/Monad/IOSimPOR.hs --- a/test/Test/Control/Monad/IOSimPOR.hs +++ b/test/Test/Control/Monad/IOSimPOR.hs @@ -45,6 +45,7 @@ import Data.List.Trace qualified as Trace import Test.QuickCheck +import Test.QuickCheck.Monadic (assert, run) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck @@ -69,9 +70,9 @@ -- , testProperty "propPermutations" propPermutations ] , testGroup "IO simulator properties" - [ testProperty "read/write graph (IOSim)" (withMaxSuccess 1000 prop_stm_graph_sim) + [ testProperty "read/write graph (IOSim)" (withNumTests 1000 prop_stm_graph_sim) , testGroup "timeouts" - [ testProperty "IOSim" (withMaxSuccess 1000 prop_timers_ST) + [ testProperty "IOSim" (withNumTests 1000 prop_timers_ST) , testProperty "IOSim: no deadlock" prop_timeout_no_deadlock_Sim , testProperty "timeout" prop_timeout , testProperty "timeouts" prop_timeouts @@ -85,8 +86,8 @@ ] ] , testProperty "infinite simulation" prop_explore_endless_simulation - , testProperty "threadId order (IOSim)" (withMaxSuccess 1000 prop_threadId_order_order_Sim) - , testProperty "forkIO order (IOSim)" (withMaxSuccess 1000 prop_fork_order_ST) + , testProperty "threadId order (IOSim)" (withNumTests 1000 prop_threadId_order_order_Sim) + , testProperty "forkIO order (IOSim)" (withNumTests 1000 prop_fork_order_ST) , testGroup "throw/catch unit tests" [ testProperty "0" unit_catch_0 , testProperty "1" unit_catch_1 @@ -123,6 +124,11 @@ , testProperty "catch: throwTo async blocking (IOSim)" $ forall_masking_states unit_catch_throwTo_masking_state_async_mayblock_ST ] + , testGroup "PropertyM callbacks" + [ testProperty "happy path" unit_monadicIOSimPOR_0 + , testProperty "failing assert" unit_monadicIOSimPOR_1 + , testProperty "exception" unit_monadicIOSimPOR_2 + ] , testProperty "evaluate unit test" unit_evaluate_0 , testGroup "forkIO unit tests" [ testProperty "1" unit_fork_1 @@ -756,6 +762,30 @@ say "after" ) $ \_ trace -> selectTraceSay trace === ["inner", "handler1", "handler2", "after"] + +unit_monadicIOSimPOR_0, unit_monadicIOSimPOR_1, unit_monadicIOSimPOR_2 + :: Property + +-- | Basic success case: a PropertyM test can be executed through IOSimPOR. +unit_monadicIOSimPOR_0 = + monadicIOSimPOR_ $ do + x <- run (pure (1 :: Int)) + assert (x == 1) + +-- | Failing assertions inside PropertyM are reported as property failures. +unit_monadicIOSimPOR_1 = + expectFailure $ + monadicIOSimPOR_ $ do + x <- run (pure (1 :: Int)) + assert (x == 2) + +-- | Exceptions thrown by the simulation are turned into failing properties via +-- `traceResult False`, matching the manual workaround from issue #229. +unit_monadicIOSimPOR_2 = + expectFailure $ + monadicIOSimPOR_ $ do + _ <- run $ evaluate (error "boom" :: ()) + assert True -- evaluate should catch pure errors unit_evaluate_0 :: Property diff --git a/test/Test/Control/Monad/Utils.hs b/test/Test/Control/Monad/Utils.hs --- a/test/Test/Control/Monad/Utils.hs +++ b/test/Test/Control/Monad/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module Test.Control.Monad.Utils where import Data.Array @@ -18,6 +19,11 @@ import Test.QuickCheck +#if !MIN_VERSION_QuickCheck(2,18,0) +withNumTests :: Testable prop => Int -> prop -> Property +withNumTests = withMaxSuccess +#endif + -- -- Read/Write graph -- @@ -489,7 +495,7 @@ -> Property forall_masking_states prop = -- make sure that the property is executed once! - withMaxSuccess 1 $ + withNumTests 1 $ foldr (\ms p -> counterexample (show ms) (prop ms) .&&. p) (property True) [Unmasked, MaskedInterruptible, MaskedUninterruptible]