如何将 MonadUnliftIO 或 MonadBaseControl 与 Hedgehog 一起使用？

Question

我有一个“测试包装器”，它为每个测试创建一个随机名称的数据库表（这样它们就不会相互干扰），并确保在测试结束时删除该表：

-- NOTE: The constraint on `m` may be incorrect because I haven't
-- been able to make this compile, and this is exactly what I'm 
-- struggling with
withRandomTable :: (MonadIO m) => Pool Connection -> (TableName -> m a) -> m a

根据我在以下链接中阅读的内容...

• https://github.com/hedgehogqa/haskell-hedgehog/issues/284
• https://github.com/hedgehogqa/haskell-hedgehog/issues/248
• https://www.stackage.org/haddock/lts-12.1/hedgehog-0.6/Hedgehog.html#v:test

...我尝试了以下变体，但失败了：

-- Attempt 1
myTest pool = property $ withRandomTable pool $ \tname -> do ...

-- Attempt 2
myTest pool = property $ do
  randomData <- forAll $ ...
  test $ withRandomTable pool $ \tname -> do ...

-- Attempts using `withRandomTableLifted`
withRandomTableLifted jobPool action = liftWith (\run -> withRandomTable jobPool (run . action)) >>= restoreT . return

-- Attempt 3
myTest pool = property . hoist runResourceT $ withRandomTableLifted pool $ \tname -> do ...

-- Attempt 4
myTest pool = property runResourceT $ do
  randomData <- forAll $ ...
  test . runResourceT $ withRandomTableLifted pool $ \tname -> do ...

-- Attempt 5 
myTest pool = property runResourceT $ do
  randomData <- forAll $ ...
  test . hoist runResourceT $ withRandomTableLifted pool $ \tname -> do ...

现在，我只是在尝试随机变化，希望任何东西都能解决这个类型级别的拼图游戏！帮助将不胜感激。

编辑

这是我第一次尝试的完整 sn-p，我使用的是 UnliftIO，但它不起作用，因为 TestT m 没有 MonadUnliftIO (TestT IO) 实例。

{-# LANGUAGE FlexibleContexts #-}
module Try where

import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import UnliftIO.Exception
import Control.Monad
import Data.Pool as Pool
import Debug.Trace
import  Control.Monad.IO.Unlift (liftIO)
import qualified System.Random as R
import Data.String (fromString)

withRandomTable pool action = do
  tname <- liftIO ((("jobs_" <>) . fromString) <$> (replicateM 10 (R.randomRIO ('a', 'z'))))
  finally
    (Pool.withResource pool $ \conn -> (liftIO $ traceM "I will create the random table here") >> (action tname))
    (Pool.withResource pool $ \conn -> liftIO $ traceM "I will drop the random table here")

myTest pool = property $ do
  randomData <- forAll $ Gen.list (Range.linear 1 100) (Gen.element [1, 2, 3])
  test $ withRandomTable pool $ \tname -> do
    traceM $ "hooray... I got the random table name " <> tname
  True === True

-- /Users/saurabhnanda/projects/haskell-pg-queue/test/Try.hs:23:10: error:
--     • No instance for (Control.Monad.IO.Unlift.MonadUnliftIO
--                          (TestT IO))
--         arising from a use of ‘withRandomTable’
--     • In the expression: withRandomTable pool
--       In the second argument of ‘($)’, namely
--         ‘withRandomTable pool
--            $ \ tname
--                -> do traceM $ "hooray... I got the random table name " <> tname’
--       In a stmt of a 'do' block:
--         test
--           $ withRandomTable pool
--               $ \ tname
-                    -> do traceM $ "hooray... I got the random table name " <> tname
--    |
-- 23 |   test $ withRandomTable pool $ \tname -> do
--    |          ^^^^^^^^^^^^^^^^^^^^

接下来，如果我使用lifted-base（我不知道我为什么要摆弄ResourceT），它似乎可以工作，但可能会在其他地方引起问题，因为我的应用程序实际代码依赖于MonadUnliftIO。鉴于TestT m 有一个MonadBaseControl 实例，是否可以安全地为UnliftIO 定义一个实例？

{-# LANGUAGE FlexibleContexts #-}
module Try where

import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Control.Exception.Lifted
import Control.Monad
import Data.Pool as Pool
import Debug.Trace
import  Control.Monad.IO.Unlift (liftIO)
import qualified System.Random as R
import Data.String (fromString)

withRandomTable pool action = do
  tname <- liftIO ((("jobs_" <>) . fromString) <$> (replicateM 10 (R.randomRIO ('a', 'z'))))
  finally
    (Pool.withResource pool $ \conn -> (liftIO $ traceM "I will create the random table here") >> (action tname))
    (Pool.withResource pool $ \conn -> liftIO $ traceM "I will drop the random table here")

myTest pool = property $ do
  randomData <- forAll $ Gen.list (Range.linear 1 100) (Gen.element [1, 2, 3])
  test $ withRandomTable pool $ \tname -> do
    traceM $ "hooray... I got the random table name " <> tname
  True === True

Answer 1

没有看到错误很难给出具体建议，但我相信你需要使用test。正如文档所写：

因为 TestT 和 PropertyT 都有 MonadTest 实例，所以这个函数不是经常需要的。然而，它可以用于直接在 TestT 中编写函数，从而以无法使用 forAll 生成额外输入为代价获得 MonadTransControl 实例。

我认为这是你关心的。