Haskell，定义类型多态的函数的专业化

Question

在刺猬中使用状态机时，我必须定义一个更新模型状态的函数。 它的类型应为forall v. Ord1 v => state v -> input v -> Var output v -> state v （请参见Update Callback构造函数）。

现在，我想output ，但是我发现的唯一函数是concrete ，但是它指定了我的更新函数v 。

如何定义一个满足Update类型的更新函数，同时又仍然允许我到达输出（大概是通过使用concrete ）？

Answer 1

知道了 您想要做的是在Hedgehog模型状态和输入（AKA转换）中使用Vars ，无论状态组件取决于先前的操作。 然后，您可以根据这些变量抽象地更新状态（即，以既可以象征性地又可以具体地起作用的方式）。 只有在执行命令时，您才能使这些变量具体化。

让我给你看一个例子。 如果您想遵循以下说明，则使用了以下导入和扩展：

{-# 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

假设我们有以下使用全局IORef的模拟Web 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模型时，我们需要记住， postFoo动作将生成UUID作为输出，以用于后续（获取和删除）动作。 以后的操作对较早的操作的这种依赖性意味着这些UUID应该在状态中显示为变量。

在我们的状态下，我们将跟踪UUID（作为变量）到Content的Map ，以对数据库的内部状态进行建模。 我们还将跟踪所有UUID的集合，甚至是那些不再存在于数据库中的UUID，因此我们可以测试已删除UUID的提取。

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

现在，我们要对发布，获取和删除命令进行建模。 要“发布”，我们需要下面的“输入”（或过渡，或任何其他形式），用于发布给定的内容：

data Post (v :: * -> *) = Post Content
  deriving (Eq, Show)

相应的命令如下所示：

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 }
      ]

请注意，无论当前状态如何，总是可以创建新的帖子，因此gen忽略当前状态并生成随机帖子。 execute将此操作转换为实际API上的IO操作。 请注意， Update回调将postFoo的结果作为变量接收 。 也就是说， o将具有Var UUID v类型。 很好，因为我们的Update仅需要在状态中存储Var UUID v由于我们构造ModelState的方式，它不需要具体的UUID值。

我们还需要Post的HTraversable实例来进行类型检查。 由于Post没有任何变量，因此该实例很简单：

instance HTraversable Post where
  htraverse _ (Post bdy) = pure (Post bdy)

对于“获取”输入和命令，我们有：

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

在这里， gen查询当前状态以获取一直观察到的UUID（在技术上，作为符号变量）的集合。 如果该集合为空，则我们没有要测试的有效UUID，因此不可能进行Get操作，并且gen返回Nothing 。 否则，我们将为集合中的随机UUID（作为符号变量）生成Get请求。 这可能是仍在数据库中的UUID或已被删除的UUID。 然后execute方法对实际的API执行IO操作。 最后，在这里，我们允许将变量具体化（我们需要获取API的实际UUID ）。

请注意回调-我们Require UUID变量是当前状态下UUID变量集的成员（以防在收缩过程中无效），并且在执行操作之后，我们Ensure可以为以下内容检索适当的内容：这个UUID。 请注意，我们可以在Ensure中将变量具体化，但是在这种情况下我们不需要这样做。 这里不需要Update ，因为Get不会影响状态。

我们还需要Get的HTraversable实例。 由于它具有变量，因此实例稍微复杂一些：

instance HTraversable Get where
  htraverse f (Get uuid) = Get <$> htraverse f uuid

“删除”输入和命令的代码与“获取”的代码非常相似，不同之处在于它具有Update回调。

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

我们要测试的属性是这些动作的随机集合的顺序应用。 请注意，由于我们的API具有全局状态， resetDatabase在每次测试开始时我们都需要resetDatabase ，否则情况会变resetDatabase奇怪：

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)

并运行它给出：

> main
✓ <interactive> passed 100 tests.
>

请注意，上面我们忘记了要检查的一件事，即该API在发布时确实提供了唯一的UUID。 例如，如果我们故意破坏我们的UUID生成器：

newUuid :: IO UUID
newUuid = do
  n <- readIORef uuidRef
  writeIORef uuidRef $ (n+1) `mod` 2
  return n

测试仍然通过-API给我们提供了重复的UUID，并且我们忠实地覆盖了模型状态下的旧数据，匹配了损坏的API。

为了检查这一点，我们想向s_post添加一个Ensure回调，以确保每个新的UUID都不是我们以前见过的。 但是，如果我们写：

, Ensure $ \before _after (Post _bdy) o ->
    assert $ o `Set.notMember` uuids before

这不会进行类型检查，因为o是一个实际的，具体的UUID输出值（即，不是Var ），但是uuids before是一组具体变量。 我们可以映射到集合以从变量中提取具体值：

, Ensure $ \before _after (Post _bdy) o ->
    assert $ o `Set.notMember` Set.map concrete (uuids before)

或者，我们可以像这样构造一个具体的变量o ：

, Ensure $ \before _after (Post _bdy) o ->
    assert $ Var (Concrete o) `Set.notMember` uuids before

两者都可以正常工作，并且可以捕获上面有问题的newUuid实现。

供参考，完整的代码是：

{-# 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)

Haskell，定义类型多态的函数的专业化

问题描述

1 个解决方案

解决方案1
1 2019-06-04 02:31:34

Haskell，定义类型多态的函数的专业化

问题描述

1 个解决方案

解决方案1 1 2019-06-04 02:31:34

解决方案1
1 2019-06-04 02:31:34