When using state machines in hedgehog I have to define a function that updates my model state. Its type should be forall v. Ord1 v => state v -> input v -> Var output v -> state v
(see Update
constructor of Callback
).
Now, I want to get to output
, but the only function I've found is concrete
, however it's specifying that v
of my update function.
How do I define an update function that satisfies the type for Update
while still letting me get to the output (presumably by using concrete
)?
Ah, I see. What you want to do is use Vars
in your Hedgehog model state and inputs (AKA transitions) wherever a state component depends on earlier actions. You then update the state in terms of these variables abstractly (ie, in a way that can work both symbolically and concretely). It's only when you execute a command that you make those variables concrete.
Let me show you an example. I've used the following imports and extensions, if you want to follow along:
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wall #-}
import Control.Monad
import Control.Monad.IO.Class
import Data.IORef
import Data.Map.Strict as Map
import Data.Map.Strict (Map)
import Data.Set as Set
import Data.Set (Set)
import System.IO.Unsafe
import Hedgehog
import Hedgehog.Gen as Gen
import Hedgehog.Range as Range
Suppose we have the following mock web API using global IORefs:
type UUID = Int
type Content = String
uuidRef :: IORef UUID
uuidRef = unsafePerformIO (newIORef 0)
newUuid :: IO UUID
newUuid = do
n <- readIORef uuidRef
writeIORef uuidRef (n+1)
return n
dbRef :: IORef (Map UUID Content)
dbRef = unsafePerformIO (newIORef Map.empty)
resetDatabase :: IO ()
resetDatabase = writeIORef dbRef Map.empty
postFoo :: Content -> IO UUID
postFoo bdy = do
uuid <- newUuid
modifyIORef dbRef (Map.insert uuid bdy)
return uuid
getFoo :: UUID -> IO (Maybe Content)
getFoo uuid = Map.lookup uuid <$> readIORef dbRef
deleteFoo :: UUID -> IO ()
deleteFoo uuid =
modifyIORef dbRef (Map.delete uuid)
In constructing the Hedgehog model, we need to keep in mind that UUIDs will be generated as output by postFoo
actions for use in subsequent (get and delete) actions. This dependency of later actions on earlier ones means that these UUIDs should appear as variables in the state.
In our state, we'll keep track of a Map
of UUIDs (as variables) to Content
to model the internal state of the database. We'll also keep track of the set of all UUIDs seen even those no longer in the database, so we can test fetching of deleted UUIDs.
data ModelState (v :: * -> *)
= S { uuids :: Set (Var UUID v) -- UUIDs ever returned
, content :: Map (Var UUID v) Content -- active content
}
deriving (Eq, Ord, Show)
initialState :: ModelState v
initialState = S Set.empty Map.empty
Now, we'll want to model post, get, and delete commands. To "post", we'll want the following "input" (or transition, or whatever), which posts the given content:
data Post (v :: * -> *) = Post Content
deriving (Eq, Show)
and the corresponding command looks like this:
s_post :: (MonadGen n, MonadIO m, MonadTest m) => Command n m ModelState
s_post =
let
gen _state = Just $ Post <$> Gen.string (Range.constant 0 100) Gen.alpha
execute (Post bdy) = liftIO $ postFoo bdy
in
Command gen execute [
Update $ \S{..} (Post bdy) o -> S { uuids = Set.insert o uuids
, content = Map.insert o bdy content }
]
Note that it's always possible to create a new post, whatever the current state, so gen
ignores the current state and generate a random post. execute
translates this action into an IO action on the actual API. Note that the Update
callback receives the result of the postFoo
as a variable . That is, o
will have type Var UUID v
. That's fine, because our Update
just needs to store a Var UUID v
in the state -- it doesn't need a concrete UUID
value because of the way we structured the ModelState
.
We'll also need an HTraversable
instance for Post
for this to typecheck. Since Post
doesn't have any variables, this instance is trivial:
instance HTraversable Post where
htraverse _ (Post bdy) = pure (Post bdy)
For the "get" input and command, we have:
data Get (v :: * -> *) = Get (Var UUID v)
deriving (Eq, Show)
s_get :: (MonadGen n, MonadIO m, MonadTest m) => Command n m ModelState
s_get =
let
gen S{..} | not (Set.null uuids) = Just $ Get <$> Gen.element (Set.toList uuids)
| otherwise = Nothing
execute (Get uuid) = liftIO $ getFoo $ concrete uuid
in
Command gen execute [
Require $ \S{..} (Get uuid) -> uuid `Set.member` uuids
, Ensure $ \before _after (Get uuid) o ->
o === Map.lookup uuid (content before)
]
Here, gen
consults the current state to get the set of ever-observed UUIDs (technically, as symbolic variables). If the set is empty, we don't have any valid UUIDs to test, so no Get
is possible, and gen
returns Nothing
. Otherwise, we generate a Get
request for a random UUID (as a symbolic variable) in the set. This may be a UUID still in the database or one that's been deleted. The execute
method then performs the IO action on the actual API. Here, finally, we're allowed to make the variable concrete (which we need to get an actual UUID
for the API).
Note the callbacks -- we Require
that the UUID variable be a member of the set of UUID variables in the current state (in case this was invalidated during shrinkage), and after the action executes, we Ensure
that we can retrieve the appropriate content for this UUID. Note that we're allowed to make variables concrete in Ensure
, but we didn't need to in this case. No Update
was needed here, since Get
doesn't affect the state.
We also need an HTraversable
instance for Get
. Since it has a variable, the instance is little more complicated:
instance HTraversable Get where
htraverse f (Get uuid) = Get <$> htraverse f uuid
The code for the "delete" input and command is much the same as for "get", except it has an Update
callback.
data Delete (v :: * -> *) = Delete (Var UUID v)
deriving (Eq, Show)
instance HTraversable Delete where
htraverse f (Delete uuid) = Delete <$> htraverse f uuid
s_delete :: (MonadGen n, MonadIO m, MonadTest m) => Command n m ModelState
s_delete =
let
gen S{..} | not (Set.null uuids) = Just $ Delete <$> Gen.element (Set.toList uuids)
| otherwise = Nothing
execute (Delete uuid) = liftIO $ deleteFoo $ concrete uuid
in
Command gen execute [
Require $ \S{..} (Delete uuid) -> uuid `Set.member` uuids
, Update $ \S{..} (Delete uuid) _o -> S { content = Map.delete uuid content, .. }
, Ensure $ \_before after (Delete uuid) _o ->
Nothing === Map.lookup uuid (content after)
]
The property we want to test is sequential application of a random collection of these actions. Note that because our API has global state, we need to resetDatabase
at the start of each test, or things will get bizarre:
prop_main :: Property
prop_main =
property $ do
liftIO $ resetDatabase
actions <- forAll $
Gen.sequential (Range.linear 1 100) initialState
[ s_post, s_get, s_delete ]
executeSequential initialState actions
Finally, then:
main :: IO ()
main = void (check prop_main)
and running this gives:
> main
✓ <interactive> passed 100 tests.
>
Note that there was one thing we forgot to check above, namely that the API genuinely provides unique UUIDs when posting. For example, if we intentinoally break our UUID generator:
newUuid :: IO UUID
newUuid = do
n <- readIORef uuidRef
writeIORef uuidRef $ (n+1) `mod` 2
return n
the testing still passes -- the API gives us duplicate UUIDs and we dutifully overwrite old data in our model state, matching the broken API.
To check this, we want to add an Ensure
callback to s_post
to ensure that each new UUID isn't one we've seen before. However if we write:
, Ensure $ \before _after (Post _bdy) o ->
assert $ o `Set.notMember` uuids before
this won't type check, because o
is an actual, concrete UUID
output value (ie, not a Var
), but uuids before
is a set of concrete variables. We could map over the set to extract the concrete values from the variables:
, Ensure $ \before _after (Post _bdy) o ->
assert $ o `Set.notMember` Set.map concrete (uuids before)
or alternatively, we can construct a concrete variable for the value o
like so:
, Ensure $ \before _after (Post _bdy) o ->
assert $ Var (Concrete o) `Set.notMember` uuids before
Both work fine and catch the buggy newUuid
implementation above.
For reference, the complete code is:
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wall #-}
import Control.Monad
import Control.Monad.IO.Class
import Data.IORef
import Data.Map.Strict as Map
import Data.Map.Strict (Map)
import Data.Set as Set
import Data.Set (Set)
import System.IO.Unsafe
import Hedgehog
import Hedgehog.Gen as Gen
import Hedgehog.Range as Range
-- * Mock API
type UUID = Int
type Content = String
uuidRef :: IORef UUID
uuidRef = unsafePerformIO (newIORef 0)
newUuid :: IO UUID
newUuid = do
n <- readIORef uuidRef
writeIORef uuidRef $ (n+1)
return n
dbRef :: IORef (Map UUID Content)
dbRef = unsafePerformIO (newIORef Map.empty)
resetDatabase :: IO ()
resetDatabase = writeIORef dbRef Map.empty
postFoo :: Content -> IO UUID
postFoo bdy = do
uuid <- newUuid
modifyIORef dbRef (Map.insert uuid bdy)
return uuid
getFoo :: UUID -> IO (Maybe Content)
getFoo uuid = Map.lookup uuid <$> readIORef dbRef
deleteFoo :: UUID -> IO ()
deleteFoo uuid =
modifyIORef dbRef (Map.delete uuid)
-- * Hedgehog model state
data ModelState (v :: * -> *)
= S { uuids :: Set (Var UUID v) -- UUIDs ever returned
, content :: Map (Var UUID v) Content -- active content
}
deriving (Eq, Ord, Show)
initialState :: ModelState v
initialState = S Set.empty Map.empty
-- * Post input/command
data Post (v :: * -> *) = Post Content
deriving (Eq, Show)
instance HTraversable Post where
htraverse _ (Post bdy) = pure (Post bdy)
s_post :: (MonadGen n, MonadIO m, MonadTest m) => Command n m ModelState
s_post =
let
gen _state = Just $ Post <$> Gen.string (Range.constant 0 100) Gen.alpha
execute (Post bdy) = liftIO $ postFoo bdy
in
Command gen execute [
Update $ \S{..} (Post bdy) o -> S { uuids = Set.insert o uuids
, content = Map.insert o bdy content }
, Ensure $ \before _after (Post _bdy) o ->
assert $ Var (Concrete o) `Set.notMember` uuids before
]
-- * Get input/command
data Get (v :: * -> *) = Get (Var UUID v)
deriving (Eq, Show)
instance HTraversable Get where
htraverse f (Get uuid) = Get <$> htraverse f uuid
s_get :: (MonadGen n, MonadIO m, MonadTest m) => Command n m ModelState
s_get =
let
gen S{..} | not (Set.null uuids) = Just $ Get <$> Gen.element (Set.toList uuids)
| otherwise = Nothing
execute (Get uuid) = liftIO $ getFoo $ concrete uuid
in
Command gen execute [
Require $ \S{..} (Get uuid) -> uuid `Set.member` uuids
, Ensure $ \before _after (Get uuid) o ->
o === Map.lookup uuid (content before)
]
-- * Delete input/command
data Delete (v :: * -> *) = Delete (Var UUID v)
deriving (Eq, Show)
instance HTraversable Delete where
htraverse f (Delete uuid) = Delete <$> htraverse f uuid
s_delete :: (MonadGen n, MonadIO m, MonadTest m) => Command n m ModelState
s_delete =
let
gen S{..} | not (Set.null uuids) = Just $ Delete <$> Gen.element (Set.toList uuids)
| otherwise = Nothing
execute (Delete uuid) = liftIO $ deleteFoo $ concrete uuid
in
Command gen execute [
Require $ \S{..} (Delete uuid) -> uuid `Set.member` uuids
, Update $ \S{..} (Delete uuid) _o -> S { content = Map.delete uuid content, .. }
, Ensure $ \_before after (Delete uuid) _o ->
Nothing === Map.lookup uuid (content after)
]
-- * Run the tests
prop_main :: Property
prop_main =
property $ do
liftIO $ resetDatabase
actions <- forAll $
Gen.sequential (Range.linear 1 100) initialState
[ s_post, s_get, s_delete ]
executeSequential initialState actions
main :: IO ()
main = void (check prop_main)
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.