A MonadTransControl instance for FreeT

Question

Is it possible to implement a MonadTransControl instance for FreeT? I started with the following, but got stuck:

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

If it is unimplementable, than why and is it possible to extend a specific free functor implementation somehow to make it implementable?

Answer 1

Disclaimer: turns out you need Traversable f constraint for MonadTransControl instance.

Warning: the instance in this answer does not obey all the laws of MonadTransControl

Pragmas and imports

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

Free monadic state

As I said in comments, the proper "monadic state" of FreeT f should be Free f (the one from Control.Monad.Free):

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

Now the implementation of restoreT changes a bit:

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

liftWith implementation

Before we look at the implementation let's see what should the type of liftWith be:

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

And Run (FreeT f) is actually

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

So the implementation would be like that:

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

The rest is simple:

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

Why Traversable?

As you can see the problem is with pushFreeT function: it uses T.mapM (which is traverse but with Monad constraint). Why do we need it there? If you look at the definition of FreeT you may notice that (NB: this is rough, I forget about Pure here):

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

And as a result of pushFreeT we need m (Free f a):

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

So we need to "push" all fs to the end and join all ms in the head. Thus we need an operation that lets us push a single f through single m and this is exactly what T.mapM pushFreeT gives us:

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

The laws

Every class instance usually come with laws. MonadTransControl is not an exception, so let's check if they hold for this instance:

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

These two laws obviously follow from laws for MonadTrans and the definition of liftWith.

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

Apparently, this law does not hold. This is because monad layers in t are collapsed when we pushFreeT. So the implemented liftWith merges effects in all layers of FreeT f m leaving us with the equivalent of m (Free f).