Run strict-mvar tests with IOSim

Author: jorisdral

strict-mvar/README.md

@@ -45,6 +45,7 @@ are distinct types.
 Although all functions that modify a checked `StrictMVar` will check the
 invariant, we do *not* guarantee that the value inside the `StrictMVar` always
 satisfies the invariant. Instead, we *do* guarantee that if the `StrictMVar` is
-updated with a value that does not satisfy the invariant, an exception is
-thrown. The reason for this weaker guarantee is that leaving an `MVar` empty can
-lead to very hard to debug "blocked indefinitely" problems.
+updated with a value that does not satisfy the invariant, an exception is thrown
+*after* the new value is written to the `StrictMVar`. The reason for this weaker
+guarantee is that leaving an `MVar` empty can lead to very hard to debug
+"blocked indefinitely" problems.

strict-mvar/strict-mvar.cabal

@@ -48,6 +48,7 @@ test-suite test
   other-modules:       Test.Control.Concurrent.Class.MonadMVar.Strict.Checked
   default-language:    Haskell2010
   build-depends:       base >=4.9 && <4.19,
+                       io-sim,
                        QuickCheck,
                        tasty,
                        tasty-quickcheck,

strict-mvar/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs

@@ -1,15 +1,29 @@
+{-# LANGUAGE RankNTypes #-}
+
 module Test.Control.Concurrent.Class.MonadMVar.Strict.Checked where
 
 import           Control.Concurrent.Class.MonadMVar.Strict.Checked
+import           Control.Monad.IOSim
+import           Test.QuickCheck.Gen.Unsafe (Capture (..), capture)
 import           Test.QuickCheck.Monadic
 import           Test.Tasty
 import           Test.Tasty.QuickCheck
 
 tests :: TestTree
 tests = testGroup "Test.Control.Concurrent.Class.MonadMVar.Strict" [
       testGroup "Checked" [
-          testProperty "prop_invariantShouldFail" prop_invariantShouldFail
-        , testProperty "prop_invariantShouldNotFail" prop_invariantShouldNotFail
+          testGroup "IO" [
+              testProperty "prop_invariantShouldFail" $
+                once $ expectFailure $ monadicIO prop_invariantShouldFail
+            , testProperty "prop_invariantShouldNotFail" $
+                once                 $ monadicIO prop_invariantShouldNotFail
+            ]
+        , testGroup "IOSim" [
+              testProperty "prop_invariantShouldFail" $
+                once $ expectFailure $ monadicSim prop_invariantShouldFail
+            , testProperty "prop_invariantShouldNotFail" $
+                once                 $ monadicSim prop_invariantShouldNotFail
+            ]
         ]
     ]
 
@@ -19,12 +33,24 @@ invPositiveInt x
   | x >= 0    = Nothing
   | otherwise = Just $ "x<0 for x=" <> show x
 
-prop_invariantShouldFail :: Property
-prop_invariantShouldFail = once $ expectFailure $ monadicIO $ run $ do
+prop_invariantShouldNotFail :: MonadMVar m => PropertyM m ()
+prop_invariantShouldNotFail = run $ do
     v <- newMVarWithInvariant invPositiveInt 0
-    modifyMVar_ v (\x -> pure $ x - 1)
+    modifyMVar_ v (\x -> pure $ x + 1)
 
-prop_invariantShouldNotFail :: Property
-prop_invariantShouldNotFail = monadicIO $ run $ do
+prop_invariantShouldFail :: MonadMVar m => PropertyM m ()
+prop_invariantShouldFail = run $ do
     v <- newMVarWithInvariant invPositiveInt 0
-    modifyMVar_ v (\x -> pure $ x + 1)
+    modifyMVar_ v (\x -> pure $ x - 1)
+
+{-------------------------------------------------------------------------------
+  Property runners (copied from "Ouroboros.Network.Testing.QuickCheck")
+-------------------------------------------------------------------------------}
+
+runSimGen :: (forall s. Gen (IOSim s a)) -> Gen a
+runSimGen f = do
+    Capture eval <- capture
+    return $ runSimOrThrow (eval f)
+
+monadicSim :: Testable a => (forall s. PropertyM (IOSim s) a) -> Property
+monadicSim m = property (runSimGen (monadic' m))