Haskell, define specialization of function that's polymorphic in type

Question

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)?

Answer 1

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 (i.e., 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 (i.e., 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)