haskell - 免费的 Monad Trans Control 实例

Question

是否可以实现 MonadTransControl FreeT 的实例？我从以下内容开始，但陷入困境:

instance (Functor f) => MonadTransControl (FreeT f) where
  newtype StT (FreeT f) r = FreeTStT r
  liftWith unlift = lift $ unlift $ error "Stuck here"
  restoreT inner = do
    FreeTStT r <- lift inner
    return r

如果它无法实现，那么为什么以及是否可以以某种方式扩展特定的自由仿函数实现以使其可实现？

Answer 1

免责声明:事实证明，您需要 MonadTransControl 实例的 Traversable f 约束。

警告:此答案中的实例不遵守 MonadTransControl

的所有法则

编译指示和导入

{-# LANGUAGE TypeFamilies #-}

import qualified Data.Traversable as T
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Trans.Control
import Control.Monad.Trans.Free
import qualified Control.Monad.Free as F

自由一元状态

正如我在评论中所说，FreeT f 的正确“一元状态”应该是 Free f (来自 Control.Monad.Free):

instance T.Traversable f => MonadTransControl (FreeT f) where
  newtype StT (FreeT f) a = StTFreeT { getStTFreeT :: F.Free f a }

现在 restoreT 的实现发生了一些变化:

  restoreT inner = do
    StTFreeT m <- lift inner
    F.toFreeT m

liftWith 实现

在查看实现之前，让我们看看 liftWith 的类型应该是什么:

liftWith :: Monad m => (Run (FreeT f) -> m a) -> FreeT f m a

而Run (FreeT f)实际上是

forall n b. Monad n => FreeT f n b -> n (StTFreeT f b)

所以实现是这样的:

liftWith unlift = lift $ unlift (liftM StTFreeT . pushFreeT)

剩下的很简单:

pushFreeT :: (T.Traversable f, Monad m) => FreeT f m a -> m (F.Free f a)
pushFreeT m = do
  f <- runFreeT m
  case f of
    Pure x -> return (return x)
    Free y -> liftM wrap $ T.mapM pushFreeT y

为什么可遍历？

正如您所看到的，问题出在 pushFreeT 函数上:它使用 T.mapM (这是 traverse 但使用 Monad约束)。为什么我们需要它？如果您查看 FreeT 的定义，您可能会注意到(注意:这很粗糙，我在这里忘记了 Pure):

FreeT f m a ~ m (f (m (f ... )))

由于 pushFreeT，我们需要 m(Free f a):

m (Free f a) ~ m (f (f (f ... )))

所以我们需要将所有f“推”到末尾，并将所有m加入头部。因此，我们需要一个操作，让我们将单个 f 推送到单个 m，这正是 T.mapM PushFreeT 为我们提供的:

mapM :: (Monad m, Traversable t) => (a -> m b) -> t a -> m (t b)
mapM pushFreeT :: Traversable t => t (FreeT t m a) -> m (t (Free t a))

法律

每个类实例通常都带有法律。 MonadTransControl 也不异常(exception)，所以让我们检查一下它们是否适用于此实例:

liftWith . const . return = return
liftWith (const (m >>= f)) = liftWith (const m) >>= liftWith . const . f

这两条定律显然遵循 MonadTrans 的定律和 liftWith 的定义。

liftWith (\run -> run t) >>= restoreT . return = t

显然，这条定律不成立。这是因为当我们 pushFreeT 时，t 中的 monad 层被折叠。因此，实现的 liftWith 合并了 FreeT f m 所有层中的效果，让我们得到了 m (Free f) 的等效项。