diff --git a/hedgehog/hedgehog.cabal b/hedgehog/hedgehog.cabal index 3a9d2d1e..efa53ca7 100644 --- a/hedgehog/hedgehog.cabal +++ b/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 diff --git a/hedgehog/src/Hedgehog/Gen.hs b/hedgehog/src/Hedgehog/Gen.hs index d6e23c4e..d092facd 100644 --- a/hedgehog/src/Hedgehog/Gen.hs +++ b/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) diff --git a/hedgehog/src/Hedgehog/Internal/State.hs b/hedgehog/src/Hedgehog/Internal/State.hs index 95117691..9c16c7e6 100644 --- a/hedgehog/src/Hedgehog/Internal/State.hs +++ b/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 diff --git a/hedgehog/test/Test/Hedgehog/State.hs b/hedgehog/test/Test/Hedgehog/State.hs new file mode 100644 index 00000000..5dda3300 --- /dev/null +++ b/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) diff --git a/hedgehog/test/test.hs b/hedgehog/test/test.hs index 1056796c..50a0bec8 100644 --- a/hedgehog/test/test.hs +++ b/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 ]