Экземпляр MonadTransControl для FreeT

Отказ от ответственности: оказывается, вам нужно Traversable f ограничение для MonadTransControl экземпляра.

Внимание: экземпляр в этом ответе не подчиняется всем законам 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

Почему Traversable?

Как видите, проблема связана с функцией pushFreeT: она использует T.mapM (то есть traverse, но с ограничением Monad). Зачем он нам там нужен? Если вы посмотрите на определение FreeT, то заметите, что (NB: это грубо, я забыл про 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 не является исключением, поэтому давайте проверим, выполняются ли они для этого экземпляра:

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

Эти два закона, очевидно, следуют из законов для MonadTrans и определения liftWith.

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

Судя по всему, этот закон не выполняется. Это связано с тем, что слои монад в t свернуты, когда мы pushFreeT. Таким образом, реализованный liftWith объединяет эффекты во всех слоях FreeT f m, оставляя нам эквивалент m (Free f).