I'm trying to build a UI with the VTY-UI library.
I'm also using a custom monad (a few monads stacked on top of eachother).
For regular IO functions, this is not a problem. I can just lift them into my monad. However, the VTY-UI function onActivate has this type signature:
onActivate :: Widget Edit -> (Widget Edit -> IO ()) -> IO ()
Is there a way to turn a Widget Edit -> MyMonad () function into a (Widget Edit -> IO ()) without having to wrap and unwrap my monad?
I'd rather not rewrite all the library's type signatures to be MonadIO m => m () instead of IO ().
The function liftBaseOpDiscard from monad-control seems to do the trick:
import Control.Monad.Trans.Control
type MyMonad a = ReaderT Int (StateT Int IO) a
onActivate' :: Widget Edit -> (Widget Edit -> MyMonad ()) -> MyMonad ()
onActivate' = liftBaseOpDiscard . onActivate
This function has a MonadBaseControl constraint, but ReaderT and StateT on top IO already have instances for that typeclass.
As the documentation for liftBaseOpDiscard mentions, changes to the state inside the callback will be discarded.
MonadBaseControl lets you temporarily hide the upper layers of a monad stack into a value of the base monad of the stack (liftBaseWith) and afterwards pop them again, if needed (restoreM).
Edit: If we need to preserve effects that take place inside the callback (like changes in the state) one solution is to "mimic" state by using an IORef as the environment of a ReaderT. Values written into the IORef are not discarded. The monad-unlift package is built around this idea. An example:
import Control.Monad.Trans.Unlift
import Control.Monad.Trans.RWS.Ref
import Data.IORef
-- use IORefs for the environment and the state
type MyMonad a = RWSRefT IORef IORef Int () Int IO a
onActivate' :: Widget Edit -> (Widget Edit -> MyMonad ()) -> MyMonad ()
onActivate' we f = do
-- the run function will unlift into IO
UnliftBase run <- askUnliftBase
-- There's no need to manually "restore" the stack using
-- restoreM, because the changes go through the IORefs
liftBase $ onActivate we (run . f)
The monad can be run afterwards using runRWSIORefT.
For the state part: you can use this module. Thanks to whoever realized that making get and put polymorphic was a good idea.
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
module IState where
import Control.Monad
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Trans.Class
import Control.Applicative
import Data.IORef
newtype IState s m a = IState (ReaderT (IORef s) m a)
runIState (IState a) s = do
sr <- liftIO $ newIORef s
runReaderT a sr
runIStateRef (IState a) r = runReaderT a r
instance (Monad m) => Monad (IState s m) where
return = IState . return
(IState a) >>= f = let
f' i = let (IState i') = f i in i'
in IState (a >>= f')
instance (Monad m,Functor m) => Applicative (IState s m) where
pure = return
(<*>) = ap
instance (Functor m) => Functor (IState s m) where
fmap f (IState a) = IState (fmap f a)
instance (MonadIO m) => MonadIO (IState s m) where
liftIO = lift . liftIO
instance (MonadState s' m) => MonadState s' (IState s m) where
get = lift get
put = lift . put
-- Because of this instance IState is almost a drop-in replacement for StateT
instance (MonadIO m) => MonadState s (IState s m) where
get = IState $ do
r <- ask
liftIO $ readIORef r
put v = IState $ do
r <- ask
liftIO $ writeIORef r v
instance MonadTrans (IState s) where
lift a = IState (lift a)
I managed to implement the suggestion mentioned in the comments of the question.
I give vty callbacks in IO that sends events down a Chan. Then i have another thread listening for those events and executing the appropriate actions in my own monad.
Related
having some trouble with a group of monads I'm trying to combine.
I'm using monad-coroutine, State and lens (as I have deeply nested state).
I had an initial approach where there was a working solution. The main point here is that I can request to execute IO tasks outside of Coroutine.
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
module Main where
import Control.Monad.Coroutine (Coroutine(..), suspend, resume)
import Control.Monad.State (State, MonadState, MonadIO)
import Control.Monad.State (lift, get, put, liftIO, runState)
import System.Environment (getArgs)
type MyType = Coroutine IORequest (State MyState)
instance (MonadState s m) => MonadState s (Coroutine IORequest m) where
get = lift get
put = lift . put
io :: MonadIO m => IO a -> m a
io = liftIO
data IORequest x = forall a. RunIO (IO a) (a -> x)
instance Functor IORequest where
fmap f (RunIO x g) = RunIO x (f . g)
data MyState = MyState { _someInt :: Int }
initialState :: MyState
initialState = MyState 1
request :: Monad m => IO a -> Coroutine IORequest m a
request x = suspend (RunIO x return)
myLogic :: MyType [String]
myLogic = do
args <- request (io getArgs)
request (io (print args))
-- do a lot of useful stuff here
return args
runMyType :: MyType [String] -> MyState -> IO ()
runMyType logic state = do
let (req, state') = runState (resume logic) state
case req of
Left (RunIO cmd q') -> do
result <- cmd
runMyType (q' result) state'
Right _ -> return ()
main :: IO ()
main = runMyType myLogic initialState
Now, at some point a simple State became not enough and I am in a need of ST. I started to try to get the ST inside StateT but for some reason cannot come up with an idea how to properly handle IO outside of coroutine. Is there any way to come up with similar runMyType when there is a change in the Coroutine?
type MyType s = Coroutine IORequest (StateT (MyState s) (ST s))
initialState :: ST s (MyState s)
initialState = do
a <- newSTRef 0
return (MyState a)
Whatever I try to come up with throws some error about s escaping or Couldn't match type ‘s’ with ‘s2’ and so on... Maybe some other order of monad stacking will help? Or is it at all possible?
And another question if you have some time: what is the difference between the above MyType s and this one:
type MyType = forall s. Coroutine IORequest (StateT (MyState s) (ST s))
I'm learning about mtl and I wish learn the proper way to create new monads as modules (not as typical application usage).
As a simple example I have written a ZipperT monad (complete code here):
{-# LANGUAGE FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
module ZipperT (
MonadZipper (..)
, ZipperT
, runZipperT
) where
import Control.Applicative
import Control.Monad.State
class Monad m => MonadZipper a m | m -> a where
pushL :: a -> m ()
pushR :: a -> m ()
...
data ZipperState s = ZipperState { left :: [s], right :: [s] }
newtype ZipperT s m a = ZipperT_ { runZipperT_ :: StateT (ZipperState s) m a }
deriving ( Functor, Applicative
, Monad, MonadIO, MonadTrans
, MonadState (ZipperState s))
instance (Monad m) => MonadZipper s (ZipperT s m) where
pushL x = modify $ \(ZipperState left right) -> ZipperState (x:left) right
pushR x = modify $ \(ZipperState left right) -> ZipperState left (x:right)
...
runZipperT :: (Monad m) => ZipperT s m a -> ([s], [s]) -> m (a, ([s], [s]))
runZipperT computation (left, right) = do
(x, ZipperState left' right') <- runStateT (runZipperT_ computation) (ZipperState left right)
return (x, (left', right'))
it's works and I can compose with other monads
import Control.Monad.Identity
import Control.Monad.State
import ZipperT
length' :: [a] -> Int
length' xs = runIdentity (execStateT (runZipperT contar ([], xs)) 0)
where contar = headR >>= \x -> case x of
Nothing -> return ()
Just _ -> do
right2left
(lift . modify) (+1)
-- ^^^^^^^
contar
But I wish to avoid the explicit lift.
What is the correct way to create modules like this?
Can I avoid the explicit lift? (I wish to hide the internal StateT structure of my ZipperT)
Thank you!
I think that if you can write an instance of MonadState for your transformer you can use modify without the lift:
instance Monad m => MonadState (ZipperT s m a) where
...
I must confess I am not sure about what part of the state modify should affect, though.
I've looked at the complete code. It seems that you already define
MonadState (ZipperState s) (ZipperT s m)
This already provides a modify which however modifies the wrong underlying state. What you actually wanted was to expose the state wrapped in m, provided that is a MonadState itself. This could theoretically be done with
instance MonadState s m => MonadState s (ZipperT s m) where
...
But now we have two MonadState instances for the same monad, causing a conflict.
I think I somehow solved this.
Here's what I did:
First, I removed the original deriving MonadState instance. I instead wrote
getZ :: Monad m => ZipperT s m (ZipperState s)
getZ = ZipperT_ get
putZ :: Monad m => ZipperState s -> ZipperT s m ()
putZ = ZipperT_ . put
modifyZ :: Monad m => (ZipperState s -> ZipperState s) -> ZipperT s m ()
modifyZ = ZipperT_ . modify
and replaced previous occurrences of get,put,modify in the ZipperT library with the above custom functions.
Then I added the new instance:
-- This requires UndecidableInstances
instance MonadState s m => MonadState s (ZipperT a m) where
get = lift get
put = lift . put
And now, the client code works without lifts:
length' :: [a] -> Int
length' xs = runIdentity (execStateT (runZipperT contar ([], xs)) 0)
where contar :: ZipperT a (StateT Int Identity) ()
contar = headR >>= \x -> case x of
Nothing -> return ()
Just _ -> do
right2left
modify (+ (1::Int))
-- ^^^^^^^
contar
In threads package in module Control.Concurrent.Thread.Group there is a function forkIO:
forkIO :: ThreadGroup -> IO α -> IO (ThreadId, IO (Result α))
I'd like to lift it using MonadBaseControl from monad-control. Here is my attempt:
fork :: (MonadBase IO m) => TG.ThreadGroup -> m α -> m (ThreadId, m (Result α))
fork tg action = control (\runInBase -> TG.forkIO tg (runInBase action))
and here is the error messsage:
Couldn't match type `(ThreadId, IO (Result (StM m α)))'
with `StM m (ThreadId, m (Result α))'
Expected type: IO (StM m (ThreadId, m (Result α)))
Actual type: IO (ThreadId, IO (Result (StM m α)))
In the return type of a call of `TG.forkIO'
In the expression: TG.forkIO tg (runInBase action)
In the first argument of `control', namely
`(\ runInBase -> TG.forkIO tg (runInBase action))'
What to change to make the types match?
The main problem is the IO a argument to forkIO. To fork an m a action in IO we'd need a way to run an m a to an IO a. To do this, we could try to make the class of monads that have a runBase :: MonadBase b m => m a -> b a method, but very few interesting transformers can provide that. If we consider for example the StateT transformer, it could figure out how to run something in the base monad with runStateT if it's first given an opportunity to observe its own state.
runFork :: Monad m => StateT s m a -> StateT s m (m b)
runFork x = do
s <- get
return $ do
(a, s') <- runStateT x s
return a
This suggests the type runForkBase :: MonadBase b m => m a -> m (b a), which we will settle on for the following type class.
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
import Control.Monad.Base
class (MonadBase b m) => MonadRunForkBase b m | m -> b where
runForkBase :: m a -> m (b a)
I added the word Fork to the name to emphasize that the future state changes will not in general be shared between the two futures. For this reason, the few interesting transformers like WriterT that could have provided a runBase only provide an uninteresting runBase; they produce side effects that will never be observable.
We can write something like fork for anything with the limited form of lowering provided by a MonadRunForkBase IO m instance. I'm going to lift the normal forkIO from base rather than the one from threads, which you can do the same way.
{-# LANGUAGE FlexibleContexts #-}
import Control.Concurrent
forkInIO :: (MonadRunForkBase IO m) => m () -> m ThreadId
forkInIO action = runForkBase action >>= liftBase . forkIO
Instances
This raises the question, "What transformers can we provide MonadRunForkBase instances for"? Straight off the bat, we can trivially provide them for any of the base monads that have MonadBase instances
import Control.Monad.Trans.Identity
import GHC.Conc.Sync (STM)
instance MonadRunForkBase [] [] where runForkBase = return
instance MonadRunForkBase IO IO where runForkBase = return
instance MonadRunForkBase STM STM where runForkBase = return
instance MonadRunForkBase Maybe Maybe where runForkBase = return
instance MonadRunForkBase Identity Identity where runForkBase = return
For transformers, it's usually easier to build up functionality like this step-by-step. Here's the class of transformers that can run a fork in the immediately underlying monad.
import Control.Monad.Trans.Class
class (MonadTrans t) => MonadTransRunFork t where
runFork :: Monad m => t m a -> t m (m a)
We can provide a default implementation for running all the way down in the base
runForkBaseDefault :: (Monad (t m), MonadTransRunFork t, MonadRunForkBase b m) =>
t m a -> t m (b a)
runForkBaseDefault = (>>= lift . runForkBase) . runFork
This lets us complete out a MonadRunForkBase instance for StateT in two steps. First, we'll use our runFork from above to make a MonadTransRunFork instance
import Control.Monad
import qualified Control.Monad.Trans.State.Lazy as State
instance MonadTransRunFork (State.StateT s) where
runFork x = State.get >>= return . liftM fst . State.runStateT x
Then we'll use the default to provide a MonadRunForkBase instance.
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
instance (MonadRunForkBase b m) => MonadRunForkBase b (State.StateT s m) where
runForkBase = runForkBaseDefault
We can do the same thing for RWS
import qualified Control.Monad.Trans.RWS.Lazy as RWS
instance (Monoid w) => MonadTransRunFork (RWS.RWST r w s) where
runFork x = do
r <- RWS.ask
s <- RWS.get
return $ do
(a, s', w') <- RWS.runRWST x r s
return a
instance (MonadRunForkBase b m, Monoid w) => MonadRunForkBase b (RWS.RWST r w s m) where
runForkBase = runForkBaseDefault
MonadBaseControl
Unlike MonadRunForkBase which we developed in the previous two sections, the MonadBaseControl from monad-control doesn't have baked in the assumption "future state changes will not in general be shared between the two futures". MonadBaseContol and control make an effort to restore the state from branching in control structures with restoreM :: StM m a -> m a. This doesn't present a problem for the forkIO from base; using forkIO is an example provided in the MonadBaseControl documentation. This will be a slight problem for the forkIO from threads because of the extra m (Result a) returned.
The m (Result a) we want will actually be returned as an IO (Result (StM m a)). We can get rid of the IO and replace it with an m with liftBase, leaving us with m (Result (StM m a)). We could convert an StM m a into an m a that restores state and then returns a with restoreM, but it is stuck inside a Result ~ Either SomeException. Either l is a functor, so we can apply restoreM everywhere inside it, simplifying the type to m (Result (m a)). Either l is also Traversable, and for any Traversable t we can always swap it inside a Monad or Applicative with sequenceA :: t (f a) -> f (t a). In this case, we can use the special purpose mapM which is a combination of fmap and sequenceA with only a Monad constraint. This would give m (m (Result a)), and the ms would be flattened together by a join in the Monad or simply using >>=. This gives rise to
{-# LANGUAGE FlexibleContexts #-}
import Control.Concurrent
import Control.Concurrent.Thread
import qualified Control.Concurrent.Thread.Group as TG
import Control.Monad.Base
import Control.Monad.Trans.Control
import Data.Functor
import Data.Traversable
import Prelude hiding (mapM)
fork :: (MonadBaseControl IO m) =>
TG.ThreadGroup -> m a -> m (ThreadId, m (Result a))
fork tg action = do
(tid, r) <- liftBaseWith (\runInBase -> TG.forkIO tg (runInBase action))
return (tid, liftBase r >>= mapM restoreM)
When we run the m (Result a) in the original thread, it will copy the state from the forked thread to the original thread, which may be useful. If you want to restore the state of the main thread after reading the Result you'll need to capture it first. checkpoint will capture the entire state and return an action to restore it.
checkpoint :: MonadBaseControl b m => m (m ())
checkpoint = liftBaseWith (\runInBase -> runInBase (return ()))
>>= return . restoreM
A complete example will show what happens to the state from two threads. Both threads get the state from when the fork happened regardless of efforts to modify the state in the other thread. When we wait for the result in the main thread, the state in the main thread is set to the state from the forked thread. We can get the main thread's state back by running the action created by checkpoint.
import Control.Monad.State hiding (mapM)
example :: (MonadState String m, MonadBase IO m, MonadBaseControl IO m) => m ()
example = do
get >>= liftBase . putStrLn
tg <- liftBase TG.new
(_, getResult) <- fork tg (get >>= put . ("In Fork:" ++) >> return 7)
get >>= put . ("In Main:" ++)
revert <- checkpoint
result <- getResult
(liftBase . print) result
get >>= liftBase . putStrLn
revert
get >>= liftBase . putStrLn
main = do
runStateT example "Initial"
return ()
This outputs
Initial
Right 7
In Fork:Initial
In Main:Initial
It seems a lot easier to maintain state through exceptions by holding on to an IORef than to try to use the State Monad. Below we have 2 alternative State Monads. One uses StateT and the other ReaderT IORef. The ReaderT IORef can easily run a final handler on the last known state.
{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
import Control.Monad.State (MonadState, execStateT, modify, StateT)
import Control.Applicative (Applicative)
import Control.Monad (void)
import Control.Monad.IO.Class ( MonadIO, liftIO )
import Data.IORef
import Control.Exception.Base
import Control.Monad.Reader (MonadReader, runReaderT, ask, ReaderT)
type StateRef = IORef Int
newtype ReadIORef a = ReadIORef { unStIORef :: ReaderT StateRef IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadReader StateRef)
newtype St a = StM { unSt :: StateT Int IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadState Int)
eval :: St a -> Int -> IO Int
eval = execStateT . unSt
evalIORef :: ReadIORef a -> StateRef -> IO a
evalIORef = runReaderT . unStIORef
add1 :: St ()
add1 = modify (+ 1)
add1Error :: St ()
add1Error = do
modify (+ 1)
error "state modified"
add1IORef :: ReadIORef Int
add1IORef = do
ioref <- ask
liftIO $ do
modifyIORef' ioref (+ 1)
readIORef ioref
add1IORefError :: ReadIORef Int
add1IORefError = do
ioref <- ask
liftIO $ do
modifyIORef' ioref (+ 1)
void $ error "IORef modified"
readIORef ioref
ignore :: IO a -> IO a
ignore action = catch action (\(_::SomeException) -> return $ error "ignoring exception")
main :: IO ()
main = do
st <- newIORef 1
resIO <- evalIORef add1IORef st >> evalIORef add1IORef st
print resIO -- 3
resSt <- eval add1 1 >>= eval add1
print resSt -- 3
stFinal <- newIORef 1
void $ ignore $ finally (evalIORef add1IORefError stFinal) (evalIORef add1IORef stFinal)
print =<< readIORef st -- 3
-- how can the final handler function use the last state of the original?
void $ ignore $ finally (eval add1Error 1) (eval add1 1)
print "?"
So at the end of the main function, how can I run a final handler that has access to the last existing state of the State Monad even when an exception is thrown? Or is the ReaderT IORef optimal or is there a better alternative?
There is a way, but let me first explain recovering state from errors in terms of ErrorT and StateT, because I find that it illuminates the general case very well.
Let's first imagine the case where ErrorT is on the outside of StateT. In other words:
m1 :: ErrorT e (StateT s m) r
If you unwrap both the ErrorT and StateT newtypes you get:
runErrorT m1
:: StateT s m (Either e r)
runStateT (runErrorT m1)
:: s -> m (Either e r, s)
The unwrapped type says that we recover the final state, even if we receive an error. So just remember that ErrorT on the outside of StateT means we can recover from errors while still preserving the current state.
Now, let's switch the order:
m2 :: StateT s (ErrorT e m r)
runStateT m2
:: s -> ErrorT e m (r, s)
runErrorT . runStateT m2
:: s -> m (Either e (r, s))
This type tells a different story: we only recover the ending state if our computation succeeds. So just remember that ErrorT on the inside of StateT means that we can't recover the state.
This might seem curious to somebody familiar with the mtl, which provides the following MonadError instance for StateT:
instance (MonadError e m) => MonadError e (StateT s m) where ...
How does StateT recover gracefully from errors after what I just said? Well, it turns out that it does not. If you write the following code:
(m :: StateT s (ErrorT e m) r) `catchError` f
... then if m uses throwError, f will begin from m's initial state, not the state that m was at when it threw the error.
Okay, so now to answer your specific question. Think of IO as having a built-in ErrorT layer by default. This means that if you can't get rid of this ErrorT layer then it will always be inside your StateT and when it throws errors you won't be able to recover the current state.
Similarly, you can think of IO as having a built-in StateT layer by default that is below the ErrorT layer. This layer conceptually holds the IORefs, and because it is "inside" the ErrorT layer it always survives errors and preserves IORef values.
This means that the only way you can use a StateT layer above the IO monad and have it survive an exception is to get rid of IOs ErrorT layer. There is only one way to do this:
Wrap every IO action in tryIO
Mask asynchronous exceptions and only unmask them in the middle of tryIO statements.
My personal recommendation is to go the IORef route since there are some people who will not be happy about masking asynchronous exceptions outside of tryIO statements, because then you cannot interrupt pure computations.
Are you throwing these exceptions, or is a library?
Because if it's the former, why not use an EitherT transformer to do the exception handling?
You just need to be careful of the order: StateT s (EitherT e IO) a won't let you see the final state if there's an error, but EitherT e (StateT s IO) a will.
StateT s (EitherT e IO) a ~ IO (Either e (s -> (a,s)))
EitherT e (StateT s IO) a ~ IO (s -> (Either e a, s))
If you're using a library that throws exceptions, and you want to maintain state then you'd need to capture the exceptions within the State monad, using lift $ catch libraryCall exceptionHandler.
If you try to catch the exception outside of the State monad, like you're doing here, then that's isomorphic to StateT s (EitherT e IO) a, as you're using the error capabilities within IO to do the catching. The state is unavailable at that level.
I have defined a simple monad transformer, EntityBuilderT, that is just a newtype over ReaderT.
data EntityBuilderState = ...
newtype EntityBuilderT m a = EntityBuilderT (ReaderT EntityBuilderState m a)
To wrap a function in a new "environment", I have written the following combinator:
withNewSource :: (Monad m) => String -> EntityBuilderT m a -> EntityBuilderT m a
withNewSource itemId builder = ...
In certain cases, I also want to build a larger transformer stack. For example:
f :: MaybeT (EntityBuilderT m) a
Obviously, I cannot apply withNewSource to this function f as the monad types no longer match. I have therefore tried to use monad-control to write a new version of such combinator.
The code I've written thus far is shown below. Though the instance definitions seems to be OK, the compiler (GHC 7.4.1) rejects the code with the following message:
Couldn't match type `IO' with `EntityBuilderT m0'
When using functional dependencies to combine
MonadBaseControl IO IO,
arising from the dependency `m -> b'
in the instance declaration in `Control.Monad.Trans.Control'
MonadBaseControl (EntityBuilderT m0) IO,
arising from a use of `control'
In the expression: control
In the expression: control $ \ run -> withNewSource itemId (run m)
I'm somewhat lost. Anyone understands what the problem really is?
{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving,
MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-}
import Control.Applicative (Applicative)
import Control.Monad (liftM)
import Control.Monad.Base
import Control.Monad.Trans (MonadTrans)
import Control.Monad.Trans.Control
import Control.Monad.Trans.Maybe (MaybeT)
import Control.Monad.Trans.Reader (ReaderT, withReaderT)
data EntityBuilderState
newtype EntityBuilderT m a = EntityBuilderT { unEB :: ReaderT EntityBuilderState m a }
deriving (Applicative, Functor, Monad, MonadTrans)
instance MonadBase b m => MonadBase b (EntityBuilderT m) where
liftBase = liftBaseDefault
instance MonadTransControl EntityBuilderT where
newtype StT EntityBuilderT a = StEB { unStEB :: StT (ReaderT EntityBuilderState) a }
liftWith f = EntityBuilderT $ liftWith $ \run ->
f $ liftM StEB . run . unEB
restoreT = EntityBuilderT . restoreT . liftM unStEB
instance MonadBaseControl b m => MonadBaseControl b (EntityBuilderT m) where
newtype StM (EntityBuilderT m) a = StMT { unStMT :: ComposeSt EntityBuilderT m a }
liftBaseWith = defaultLiftBaseWith StMT
restoreM = defaultRestoreM unStMT
withNewSource :: (Monad m) => String -> EntityBuilderT m a -> EntityBuilderT m a
withNewSource itemId (EntityBuilderT m) = EntityBuilderT (withReaderT undefined m)
withNewSource' :: String -> MaybeT (EntityBuilderT IO) a -> MaybeT (EntityBuilderT IO) a
withNewSource' itemId m = control $ \run -> withNewSource itemId (run m)
The problem is that, because the base monad is IO, run has type MaybeT (EntityBuilderT IO) a -> IO (StM (MaybeT (EntityBuilderT IO) a)), but you're using its return value as an EntityBuilderT IO action. Additionally, the return value of the function you pass to control must be in IO, not EntityBuilderT IO.
This is because your MonadBaseControl instance says that you lift things into the base monad of the transformed monad m; since the base of MaybeT (EntityBuilderT IO) is IO, control takes a function from RunInBase (MaybeT (EntityBuilderT IO)) IO to IO (StM (MaybeT (EntityBuilderT IO)) a).
Unfortunately, I'm not experienced enough with monad-control to suggest a solution; perhaps you could use MaybeT's MonadTransControl instance to achieve the "one level down" functionality?