Работа с API-интерфейсом MonadBaseControl

В настоящее время я играю с библиотекой Bryan O'Sullivan resource-pool и задаю вопрос о расширении withResource. Я хочу изменить подпись функции withResource от (MonadBaseControl IO m) => Pool a -> (a -> m b) -> m b до (MonadBaseControl IO m) => Pool a -> (a -> m (Bool, b)) -> m b.
То, что я хочу достичь, заключается в том, что действие должно возвращать кортеж (Bool, b), где булевское значение указывает, должен ли заемный ресурс возвращаться в пул или уничтожаться.

Теперь моя текущая реализация выглядит следующим образом:

withResource :: forall m a b. (MonadBaseControl IO m) => Pool a -> (a -> m (Bool, b)) -> m b
{-# SPECIALIZE withResource :: Pool a -> (a -> IO (Bool,b)) -> IO b #-}
withResource pool act = fmap snd result
  where
    result :: m (Bool, b)
    result = control $ \runInIO -> mask $ \restore -> do
      resource <- takeResource pool
      ret <- restore (runInIO (act resource)) `onException`
             destroyResource pool resource

      void . runInIO $ do
        (keep, _) <- restoreM ret :: m (Bool, b)

        if keep
          then liftBaseWith . const $ putResource pool resource
          else liftBaseWith . const $ destroyResource pool resource

      return ret

И у меня есть ощущение, что это не так, как должно выглядеть... Возможно, я не использую API MonadBaseControl API. Что вы, ребята, думаете об этом и как я могу улучшить его, чтобы быть более идиоматичным?

ОТВЕТЫ

Ответ 1

У меня такое чувство, что существует фундаментальная проблема с этим подходом. Для монад, для которых StM M a равно/изоморфно a, это сработает. Но для других монадов возникнет проблема. Пусть рассмотрим MaybeT IO. Действие типа a -> MaybeT IO (Bool, b) может завершиться неудачей, поэтому не будет получено значение Bool. И код в

  void . runInIO $ do
    (keep, _) <- restoreM ret :: m (Bool, b)
    ...

не будет выполняться, поток управления остановится на restoreM. А для ListT IO это будет еще хуже, так как putResource и destroyResource будут выполняться несколько раз. Рассмотрим эту примерную программу, которая является упрощенной версией вашей функции:

{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, RankNTypes, TupleSections #-}
import Control.Monad
import Control.Monad.Trans.Control
import Control.Monad.Trans.List

foo :: forall m b . (MonadBaseControl IO m) => m (Bool, b) -> m b
foo act = fmap snd result
  where
    result :: m (Bool, b)
    result = control $ \runInIO -> do
      ret <- runInIO act

      void . runInIO $ do
        (keep, _) <- restoreM ret :: m (Bool, b)

        if keep
          then liftBaseWith . const $ putStrLn "return"
          else liftBaseWith . const $ putStrLn "destroy"

      return ret

main :: IO ()
main = void . runListT $ foo f
  where
    f = msum $ map (return . (, ())) [ False, True, False, True ]

Он напечатает

destroy
return
destroy
return

И для пустого списка ничего не печатается, а это означает, что в вашей функции не будет вызываться очистка.

Я должен сказать, что я не уверен, как лучше достичь своей цели. Я бы попытался исследовать в направлении подписи

withResource :: forall m a b. (MonadBaseControl IO m)
             => Pool a -> (a -> IO () -> m b) -> m b

где аргумент IO () будет функцией, которая при выполнении аннулирует текущий ресурс и помещает его для уничтожения. (Или, для лучшего удобства, замените IO () поднятым m ()). Затем, внутренне, как это было на уровне IO, я просто создал вспомогательный MVar, который был бы reset путем вызова функция, а в конце, в зависимости от значения, возвратите или уничтожьте ресурс.