Add parallel' and sequential' that take a generator of commands

hedgehog/hedgehog.cabal

@@ -134,6 +134,7 @@ test-suite test
     Test.Hedgehog.Filter
     Test.Hedgehog.Maybe
     Test.Hedgehog.Seed
+    Test.Hedgehog.State
     Test.Hedgehog.Text
     Test.Hedgehog.Zip
 

hedgehog/src/Hedgehog/Gen.hs

@@ -96,7 +96,9 @@ module Hedgehog.Gen (
 
   -- ** Abstract State Machine
   , sequential
+  , sequential'
   , parallel
+  , parallel'
 
   -- * Sampling Generators
   , sample
@@ -107,6 +109,6 @@ module Hedgehog.Gen (
   ) where
 
 import           Hedgehog.Internal.Gen
-import           Hedgehog.Internal.State (sequential, parallel)
+import           Hedgehog.Internal.State (sequential, sequential', parallel, parallel')
 
 import           Prelude hiding (filter, print, maybe, map, seq)

hedgehog/src/Hedgehog/Internal/State.hs

@@ -46,7 +46,9 @@ module Hedgehog.Internal.State (
   , dropInvalid
   , action
   , sequential
+  , sequential'
   , parallel
+  , parallel'
   , executeSequential
   , executeParallel
   ) where
@@ -55,7 +57,7 @@ import qualified Control.Concurrent.Async.Lifted as Async
 import           Control.Monad (foldM, foldM_)
 import           Control.Monad.Catch (MonadCatch)
 import           Control.Monad.State.Class (MonadState, get, put, modify)
-import           Control.Monad.Morph (MFunctor(..))
+import           Control.Monad.Morph (MFunctor(hoist))
 import           Control.Monad.Trans.Class (lift)
 import           Control.Monad.Trans.Control (MonadBaseControl)
 import           Control.Monad.Trans.State (State, runState, execState)
@@ -530,18 +532,18 @@ dropInvalid =
   in
     fmap Maybe.catMaybes . traverse loop
 
--- | Generates a single action from a set of possible commands.
+-- | Generates a single action from a generator of commands.
 --
 action ::
      (MonadGen gen, MonadTest m)
-  => [Command gen m state]
+  => gen (Command gen m state)
   -> GenT (StateT (Context state) (GenBase gen)) (Action m state)
-action commands =
+action commandsGen =
   Gen.justT $ do
     Context state0 _ <- get
 
     Command mgenInput exec callbacks <-
-      Gen.element $ filter (\c -> commandGenOK c state0) commands
+      hoist lift $ Gen.toGenT $ Gen.filterT (\c -> commandGenOK c state0) commandsGen
 
     input <-
       case mgenInput state0 of
@@ -568,11 +570,11 @@ action commands =
 genActions ::
      (MonadGen gen, MonadTest m)
   => Range Int
-  -> [Command gen m state]
+  -> gen (Command gen m state)
   -> Context state
   -> gen ([Action m state], Context state)
-genActions range commands ctx = do
-  xs <- Gen.fromGenT . (`evalStateT` ctx) . distributeT $ Gen.list range (action commands)
+genActions range commandsGen ctx = do
+  xs <- Gen.fromGenT . (`evalStateT` ctx) . distributeT $ Gen.list range (action commandsGen)
   pure $
     dropInvalid xs `runState` ctx
 
@@ -640,9 +642,19 @@ sequential ::
   -> (forall v. state v)
   -> [Command gen m state]
   -> gen (Sequential m state)
-sequential range initial commands =
+sequential range initial commands = sequential' range initial (Gen.element commands)
+
+-- | Generates a sequence of actions from an initial model state and a generator of commands.
+--
+sequential' ::
+     (MonadGen gen, MonadTest m)
+  => Range Int
+  -> (forall v. state v)
+  -> gen (Command gen m state)
+  -> gen (Sequential m state)
+sequential' range initial commandsGen =
   fmap (Sequential . fst) $
-    genActions range commands (mkContext initial)
+    genActions range commandsGen (mkContext initial)
 
 -- | A sequential prefix of actions to execute, with two branches to execute in parallel.
 --
@@ -686,10 +698,23 @@ parallel ::
   -> (forall v. state v)
   -> [Command gen m state]
   -> gen (Parallel m state)
-parallel prefixN parallelN initial commands = do
-  (prefix, ctx0) <- genActions prefixN commands (mkContext initial)
-  (branch1, ctx1) <- genActions parallelN commands ctx0
-  (branch2, _ctx2) <- genActions parallelN commands ctx1 { contextState = contextState ctx0 }
+parallel prefixN parallelN initial commands = parallel' prefixN parallelN initial (Gen.element commands)
+
+-- | Given the initial model state and a generator of commands, generates prefix
+--   actions to be run sequentially, followed by two branches to be run in
+--   parallel.
+--
+parallel' ::
+     (MonadGen gen, MonadTest m)
+  => Range Int
+  -> Range Int
+  -> (forall v. state v)
+  -> gen (Command gen m state)
+  -> gen (Parallel m state)
+parallel' prefixN parallelN initial commandsGen = do
+  (prefix, ctx0) <- genActions prefixN commandsGen (mkContext initial)
+  (branch1, ctx1) <- genActions parallelN commandsGen ctx0
+  (branch2, _ctx2) <- genActions parallelN commandsGen ctx1 { contextState = contextState ctx0 }
 
   pure $ Parallel prefix branch1 branch2
 

hedgehog/test/Test/Hedgehog/State.hs

@@ -0,0 +1,96 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE KindSignatures #-}
+module Test.Hedgehog.State (tests) where
+
+import           Control.Monad.IO.Class (MonadIO)
+import           Data.IORef (IORef, readIORef, atomicModifyIORef', newIORef)
+import           Data.Kind (Type)
+import           Hedgehog
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+
+data State = State (IORef Int)
+
+createState :: IO State
+createState = State <$> newIORef 0
+
+counterValue :: State -> IO Int
+counterValue (State ref) = readIORef ref
+
+incrementState :: State -> IO ()
+incrementState (State ref) = atomicModifyIORef' ref (\x -> (x+1,()))
+
+decrementState :: State -> IO ()
+decrementState (State ref) = atomicModifyIORef' ref (\x -> (x-1,()))
+
+data Model (v :: Type -> Type) = Model Int
+
+data Increment (v :: Type -> Type) = Increment deriving Show
+instance HTraversable Increment where
+  htraverse _ Increment = pure Increment
+
+data Decrement (v :: Type -> Type) = Decrement deriving Show
+instance HTraversable Decrement where
+  htraverse _ Decrement = pure Decrement
+
+data GetCounter (v :: Type -> Type) = GetCounter deriving Show
+instance HTraversable GetCounter where
+  htraverse _ GetCounter = pure GetCounter
+
+cIncrement :: forall gen m. (MonadGen gen, MonadTest m, MonadIO m)
+           => State
+           -> Command gen m Model
+cIncrement s = Command gen exec cbs
+  where
+    gen :: Model Symbolic -> Maybe (gen (Increment Symbolic))
+    gen _ = Just (pure Increment)
+    exec :: Increment Concrete -> m ()
+    exec _ = evalIO (incrementState s)
+    cbs = [ Update $ \(Model value) _i _o -> Model (value + 1)
+          ]
+
+cDecrement :: forall gen m. (MonadGen gen, MonadTest m, MonadIO m)
+           => State
+           -> Command gen m Model
+cDecrement s = Command gen exec cbs
+  where
+    gen :: Model Symbolic -> Maybe (gen (Decrement Symbolic))
+    gen _ = Just (pure Decrement)
+    exec :: Decrement Concrete -> m ()
+    exec _ = evalIO (decrementState s)
+    cbs = [ Update $ \(Model value) _i _o -> Model (value - 1)
+          ]
+
+cGetCounter :: forall gen m. (MonadGen gen, MonadTest m, MonadIO m)
+           => State
+           -> Command gen m Model
+cGetCounter s = Command gen exec cbs
+  where
+    gen :: Model Symbolic -> Maybe (gen (GetCounter Symbolic))
+    gen _ = Just (pure GetCounter)
+    exec :: GetCounter Concrete -> m Int
+    exec _ = evalIO (counterValue s)
+    cbs = [ Ensure $ \_oldState (Model modelValue) _i retrievedValue -> modelValue === retrievedValue
+          ]
+
+commandsGen :: (MonadGen gen, MonadTest m, MonadIO m)
+            => State
+            -> gen (Command gen m Model)
+commandsGen s = Gen.frequency $
+  zipWith
+    (\freq cmd -> (freq, pure (cmd s)))
+    [1, 1, 2]
+    [cIncrement, cDecrement, cGetCounter]
+
+prop_commands_gen :: Property
+prop_commands_gen =
+  property $ do
+    state <- evalIO createState
+    let initialModel = Model 0
+    actions <- forAll $ Gen.sequential' (Range.linear 1 10) initialModel (commandsGen state)
+    executeSequential initialModel actions
+
+tests :: IO Bool
+tests =
+  checkParallel $$(discover)

hedgehog/test/test.hs

@@ -5,6 +5,7 @@ import qualified Test.Hedgehog.Confidence
 import qualified Test.Hedgehog.Filter
 import qualified Test.Hedgehog.Maybe
 import qualified Test.Hedgehog.Seed
+import qualified Test.Hedgehog.State
 import qualified Test.Hedgehog.Text
 import qualified Test.Hedgehog.Zip
 
@@ -17,6 +18,7 @@ main =
     , Test.Hedgehog.Filter.tests
     , Test.Hedgehog.Maybe.tests
     , Test.Hedgehog.Seed.tests
+    , Test.Hedgehog.State.tests
     , Test.Hedgehog.Text.tests
     , Test.Hedgehog.Zip.tests
     ]