Parallel state machine testing

hedgehog-example/test/Test/Example/References.hs

@@ -136,8 +136,8 @@ instance HTraversable IncRef where
   htraverse f (IncRef ref) =
     IncRef <$> htraverse f ref
 
-incRef :: (Monad n, MonadIO m) => Command n m State
-incRef =
+incRef :: (Monad n, MonadIO m) => Int -> Command n m State
+incRef n =
   let
     gen s =
       case stateRefs s of
@@ -149,7 +149,7 @@ incRef =
 
     execute (IncRef ref) = do
       x <- liftIO $ IORef.readIORef (opaque ref)
-      liftIO $ IORef.writeIORef (opaque ref) (x + 2) -- deliberate bug
+      liftIO $ IORef.writeIORef (opaque ref) (x + n) -- deliberate bug
   in
     Command gen execute [
         Require $ \(State xs) (IncRef ref) ->
@@ -166,14 +166,33 @@ incRef =
 
 ------------------------------------------------------------------------
 
-prop_references :: Property
-prop_references =
+prop_references_sequential :: Property
+prop_references_sequential =
   property $ do
     actions <- forAll $
-      Gen.actions (Range.linear 1 100) initialState [newRef, readRef, writeRef, incRef]
+      Gen.sequential (Range.linear 1 100) initialState [
+          newRef
+        , readRef
+        , writeRef
+        , incRef 2
+        ]
 
     executeSequential initialState actions
 
+prop_references_parallel :: Property
+prop_references_parallel =
+  withTests 1000 . withRetries 10 . property $ do
+    actions <- forAll $
+      Gen.parallel (Range.linear 1 50) (Range.linear 1 10) initialState [
+          newRef
+        , readRef
+        , writeRef
+        , incRef 1
+        ]
+
+    test $
+      executeParallel initialState actions
+
 ------------------------------------------------------------------------
 
 return []

hedgehog-example/test/Test/Example/Registry.hs

@@ -21,6 +21,7 @@ import qualified Data.Set as Set
 
 import           Hedgehog
 import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Internal.State as Gen
 import qualified Hedgehog.Range as Range
 
 import           System.IO.Unsafe (unsafePerformIO)
@@ -247,23 +248,39 @@ ioUnregister (Name name) = do
   when (isNothing m) $
     fail "ioUnregister: not registered"
 
-  -- Uncomment to fix implementation
-  --HashTable.delete procTable name
+  HashTable.delete procTable name
 
 ------------------------------------------------------------------------
 
-prop_registry :: Property
-prop_registry =
+prop_registry_sequential :: Property
+prop_registry_sequential =
   property $ do
     actions <- forAll $
-      Gen.actions (Range.linear 1 100) initialState [spawn, register, unregister]
+      Gen.sequential
+        (Range.linear 1 100)
+        initialState
+        [spawn, register, unregister]
 
     evalIO ioReset
-    executeSequential initialState actions
+    Gen.executeSequential initialState actions
+
+prop_registry_parallel :: Property
+prop_registry_parallel =
+  withRetries 10 . property $ do
+    actions <- forAll $
+      Gen.parallel
+        (Range.linear 1 100)
+        (Range.linear 1 10)
+        initialState
+        [spawn, register, unregister]
+
+    test $ do
+      evalIO ioReset
+      Gen.executeParallel initialState actions
 
 ------------------------------------------------------------------------
 
 return []
 tests :: IO Bool
 tests =
-  checkParallel $$(discover)
+  checkSequential $$(discover)

hedgehog/hedgehog.cabal

@@ -54,6 +54,7 @@ library
     , containers                      >= 0.4        && < 0.6
     , directory                       >= 1.2        && < 1.4
     , exceptions                      >= 0.7        && < 0.9
+    , lifted-async                    >= 0.7        && < 0.10
     , mmorph                          >= 1.0        && < 1.2
     , monad-control                   >= 1.0        && < 1.1
     , mtl                             >= 2.1        && < 2.3

hedgehog/src/Hedgehog.hs

@@ -46,11 +46,18 @@
 module Hedgehog (
   -- * Properties
     Property
+  , PropertyT
   , Group(..)
   , PropertyName
   , GroupName
 
   , property
+  , test
+
+  , forAll
+  , forAllWith
+  , discard
+
   , check
   , recheck
 
@@ -67,21 +74,19 @@ module Hedgehog (
   , withShrinks
   , ShrinkLimit
 
+  , withRetries
+  , ShrinkRetries
+
   -- * Generating Test Data
   , Gen
   , Range
   , Size(..)
   , Seed(..)
 
-  , TestGen
-  , forAll
-  , forAllWith
-  , discard
-  , test
-
   -- * Tests
   , Test
-  , MonadTest
+  , TestT
+  , MonadTest(..)
   , annotate
   , annotateShow
   , footnote
@@ -102,7 +107,10 @@ module Hedgehog (
   , Command(..)
   , Callback(..)
   , Action
+  , Sequential(..)
+  , Parallel(..)
   , executeSequential
+  , executeParallel
 
   , Var(..)
   , concrete
@@ -138,20 +146,22 @@ import           Hedgehog.Internal.Property (annotate, annotateShow)
 import           Hedgehog.Internal.Property (assert, (===))
 import           Hedgehog.Internal.Property (discard, failure, success)
 import           Hedgehog.Internal.Property (DiscardLimit, withDiscards)
-import           Hedgehog.Internal.Property (footnote, footnoteShow)
-import           Hedgehog.Internal.Property (forAll, forAllWith)
 import           Hedgehog.Internal.Property (eval, evalM, evalIO)
 import           Hedgehog.Internal.Property (evalEither, evalExceptT)
+import           Hedgehog.Internal.Property (footnote, footnoteShow)
+import           Hedgehog.Internal.Property (forAll, forAllWith)
 import           Hedgehog.Internal.Property (MonadTest(..))
-import           Hedgehog.Internal.Property (Property, PropertyName, Group(..), GroupName)
+import           Hedgehog.Internal.Property (Property, PropertyT, PropertyName, Group(..), GroupName)
 import           Hedgehog.Internal.Property (ShrinkLimit, withShrinks)
-import           Hedgehog.Internal.Property (Test, TestGen, property, test)
+import           Hedgehog.Internal.Property (ShrinkRetries, withRetries)
+import           Hedgehog.Internal.Property (Test, TestT, property, test)
 import           Hedgehog.Internal.Property (TestLimit, withTests)
 import           Hedgehog.Internal.Range (Range, Size(..))
 import           Hedgehog.Internal.Runner (check, recheck, checkSequential, checkParallel)
 import           Hedgehog.Internal.Seed (Seed(..))
-import           Hedgehog.Internal.State (Command(..), Callback(..), Action)
-import           Hedgehog.Internal.State (executeSequential)
+import           Hedgehog.Internal.State (Command(..), Callback(..))
+import           Hedgehog.Internal.State (Action, Sequential(..), Parallel(..))
+import           Hedgehog.Internal.State (executeSequential, executeParallel)
 import           Hedgehog.Internal.State (Var(..), Symbolic, Concrete(..), concrete, opaque)
 import           Hedgehog.Internal.TH (discover)
 import           Hedgehog.Internal.Tripping (tripping)

hedgehog/src/Hedgehog/Gen.hs

@@ -94,7 +94,8 @@ module Hedgehog.Gen (
   , shuffle
 
   -- ** Abstract State Machine
-  , actions
+  , sequential
+  , parallel
 
   -- * Sampling Generators
   , sample
@@ -105,6 +106,6 @@ module Hedgehog.Gen (
   ) where
 
 import           Hedgehog.Internal.Gen
-import           Hedgehog.Internal.State (actions)
+import           Hedgehog.Internal.State (sequential, parallel)
 
 import           Prelude hiding (filter, print, maybe, map, seq)