Compatibility function to make MonadUnliftIO and MonadBaseControl IO work together

mbc.hs

{-

Oh no! You're lost in a twisty maze of IO lifting and unlifting, and you've come to
an impossible fork: you're currently in some monad that is `MonadBaseControl IO m`,
but you need to call a function in `MonadUnliftIO`. AND you need to call functions 
in your original monad transformer, too!

We can make this work, but it's a bit hairy.

MonadUnliftIO is a strictly less powerful type class than `MonadBaseControl IO`, so
in theory, any `MonadUnliftIO` can be instantiated as `MonadBaseControl IO` with a
pure `StM` type. But actually making the interop work is difficult.

I ran into this issue while trying to develop an integration with the database library
`persistent` and the testing library `hedgehog`. I need to run a database action and
make assertions about the result. The function to run database actions in `persistent`
is essentially:

    runSqlConn :: (MonadUnliftIO m) => SqlBackend -> SqlPersistT m a -> m a
    
We want to make test assertions in the `SqlPersistT` action. You might, very sensibly, ask:

> Why not just run your database action, return a value from that, and make assertions?
> I mean, look, this is easy!

-}

syntax :: SqlBackend -> PropertyT IO ()
syntax db = do
  setup <- Gen.forAll generators
  result <- liftIO $ flip runSqlConn db $ do
    insertSetup setup
    queryUnderTest
  result === expectedValue
  
{-

... And, yeah, that's actually really easy! That solves the problem if you don't
need to interleave database actions and assertions. It's also nice if you're only
returning one or two values from the database to perform assertions on, but it's
very annoying to write:

-}

annoyingSyntax :: SqlBackend -> PropertyT IO ()
annoyingSyntax db = do
  setup <- Gen.forAll generators
  (a, b, c, d) <- liftIO $ flip runSqlConn db $ do
    insertSetup setup
    a <- queryUnderTest
    b <- queryUnderTest2
    c <- queryUnderTest3
    d <- queryUnderTest4
    pure (a, b, c, d)
  a === expectedValue
  b === whatever
  c === foobar
  d === you got it
  
{-

Plus, if we need to make an assertion about `a` before we ever produce the `b`, we're 
stuck. The test runner resets the transaction whenever you run the database action,
so splitting out the db into separate actions will wipe away the original state. We
need a way to interleave these concerns.

We can use `MonadBaseControl` and `MonadIO` to provide our initial start.

-}

first :: SqlBackend -> PropertyT IO ()
first db = do
  i <- forAll Gen.whatever
  j <- forAll Gen.thingy
  k <- forAll Gen.makeStuff j
  
  control $ \runInIO -> do
    flip runSqlConn db $ do
       a <- dbQuery1
       liftIO $ runInIO $ a === expectedA
       b <- dbQuery2 a
       liftIO $ runInIO $ b === expectedB

{-

This works, but requiring people to know how to use MonadBaseControl to write a test
is a little much. Let's make the interface a bit more palatable.

-}

embedDatabase
  :: TestDb
  -> WithDbAssert a
  -> PropertyT IO a
embedDatabase db fn =
  control $ \runInIO ->
    runTestDb db (fn (liftIO . runInIO))

second :: SqlBackend -> PropertyT IO ()
second db = do
  i <- forAll Gen.whatever
  j <- forAll Gen.thingy
  k <- forAll Gen.makeStuff j
  embedDatabase db $ \assert -> do
    insert i
    insert j
    insert k
    a <- runQueryA
    assert $ a === expectedA
    b <- runQueryB
    assert $ b === expectedB
    c <- runQueryC 
    assert $ c === expectedC

{- 

The type `WithDbAssert a` is going to be a bit nasty.

-}

type WithDbAssert a =
  (forall x. PropertyT IO x -> SqlPersistT IO (StM (PropertyT IO) x))
  -> SqlPersistT IO (StM (PropertyT IO) a)


{-

It's a function. The first parameter is itself a function, and that function takes a 
`PropertyT IO x` and runs it in `SqlPersistT IO`, but *also* captures the monadic state
of `PropertyT` in the return.

The return type is an action in `SqlPersistT IO` capturing the monadic state of 
`PropertyT IO` and returning some value of type `a`.

Getting this type right took me kind of a long time.

Anyway, it turns out we can generalize this into a function which can run any `UnliftIO`
in any `MonadBaseControl IO m` and provide a callback for running the `MonadBaseControl IO`
actions:

-}

embed
  :: (MonadBaseControl IO n, MonadIO m)
  => (forall a. m a -> IO a)
  -> WithAssert n m b
  -> n b
embed unlift action =
  control $ \runInIO -> unlift (action (liftIO . runInIO))

type WithAssert n m b =
  ( (forall x. n x -> m (StM n x))
  -> m (StM n b)
  )
  
{-

We can now rewrite our database embedding like this:

-}

type WithDbAssert a = WithAssert (PropertyT IO) (SqlPersistT IO) a

embedDatabase :: TestDb -> WithDbAssert a -> PropertyT IO a
embedDatabase db = embed (runTestDb db)

This doesn't actually work, dang!

If you run something like:

embed runStuff $ \assert -> do
  foo
  assert something
  bar
  assert somethingElse

This type-checks, but as is usually the case with MonadBaseControl, it doesn't do what you want. To better understand why, consider this semantically identical code:

embed runStuff $ \assert -> do
  foo
  testResult <- assert something
  bar
  testResult2 <- assert somethingElse
  pure testResult2

assert, as defined in this blog post, returns SqlPersistT IO (StM (PropertyT IO) a). That StM is the monadic state of PropertyT, which is whether or not the test failed. We can solve this with the hedgehog case by writing:

embed runStuff $ \assert -> do
  foo
  testResult <- assert something
  bar
  testResult2 <- assert somethingElse
  pure (testResult <|> testResult2)

But, ugh, that's not really user friendly! So the hedgehog specific stuff is going to need to use some machinery beyond this.