[SOLVED] How to use MonadUnliftIO or MonadBaseControl with Hedgehog?

How to use MonadUnliftIO or MonadBaseControl with Hedgehog?

I've got a "test wrapper" that creates a DB table with a random name for each test (so that they don't interfere with each other), and ensures that the table is dropped when the test ends:

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

Based on what I read on the following links...

... I've tried the following variations, but failed:

-- 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 ...

Now, I'm just trying random variations hoping for anything to solve this type-level jigsaw puzzle! Help would be appreciated.

Edit

Here's a complete snippet of my first try, where I'm using UnliftIO, but it doesn't work because TestT m doesn't have a MonadUnliftIO (TestT IO) instance.

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

Next, if I use lifted-base (I don't know why I was fiddling around with ResourceT), it seems to work, but may cause problems elsewhere, because my app's actual code is dependent on MonadUnliftIO. Given that TestT m has a MonadBaseControl instance, is it possible to define an instance for UnliftIO safely?

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

Solution

Without seeing the errors it's hard to give specific advice, but I believe you need to use test. As the documentation writes:

Because both TestT and PropertyT have MonadTest instances, this function is not often required. It can however be useful for writing functions directly in TestT and thus gaining a MonadTransControl instance at the expense of not being able to generate additional inputs using forAll.

Which I think is what you care about here.