Create my own state monad transformer module hiding underlying state monad - haskell

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

Related

Can the type of this function be declared in standard Haskell

The following program compiles under GHC 8.0.2 with no language extensions, and produces the expected two lines of output.
However, it does not compile if the (non-top-level) type declaration for the value write' is removed.
Also, I cannot find any (top-level) type declaration for the function write.
I find this rather odd. If this is acceptable standard Haskell, surely it should be possible to create a type declaration for the function write.
So my question is: is there such a type declaration?
import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
import Control.Monad.Writer (MonadTrans, Writer, lift, runWriter, tell, when)
import ListT (ListT, toList) -- Volkov's list-t package
logging = True
write x = when logging write' where
write' :: MonadTrans m => m (Writer [String]) ()
write' = lift $ tell [x]
f :: ListT (Writer [String]) String
f = do
write "Hello from f"
return "ABC"
g :: MaybeT (Writer [String]) Int
g = do
write "Hello from g"
return 123
main :: IO ()
main = do
print $ runWriter $ toList f
print $ runWriter $ runMaybeT g
Using GHCi (remember to put this into a separate file and load it on GHCi's command line lest you get confused by GHCi's altered typing rules):
> :t write
write :: (Applicative (m (Writer [String])), MonadTrans m) =>
String -> m (Writer [String]) ()
Why? Well,
write' :: MonadTrans m => m (Writer [String]) ()
when :: Applicative f => Bool -> f () -> f ()
when logging :: Applicative f => f () -> f ()
so, when logging write' must unify write''s m (Writer [String]) with when loggings's f, causing the combined constraint (Applicative (m (Writer [String])), MonadTrans m). But wait, let's remove the type signatures and see what the most general type is:
-- equivalent but slightly easier to talk about
write = when logging . lift . tell . (:[])
(:[]) :: a -> [a]
tell :: MonadWriter w m -> w -> m ()
lift :: (Monad m, MonadTrans t) => m a -> t m a
tell . (:[]) :: MonadWriter [a] m => a -> m ()
lift . tell . (:[]) :: (MonadWriter [a] m, MonadTrans t) => a -> t m ()
when logging . lift . tell . (:[]) = write
:: (Applicative (t m), MonadWriter [a] m, MonadTrans t) => a -> t m ()
-- GHCi agrees
Per se, there's nothing wrong with this type. However, standard Haskell does not allow this. In standard Haskell, a constraint must be of the form C v or C (v t1 t2 ...) where v is a type variable. In the compiling case, this holds: the Applicative constraint has the type variable m on the outside, and the MonadTrans is just m. This is true in the non-compiling version, too, but we also have the constraint MonadWriter ([] a) m. [] is no type variable, so the type here is rejected. This constraint arises in the compiling version, too, but the type signatures nail the variables down to produce MonadWriter [String] (Writer [String]), which is immediately satisfied and does not need to appear in the context of write.
The restriction is lifted by enabling FlexibleContexts (preferably via a {-# LANGUAGE FlexibleContexts #-} pragma, but also maybe by -XFlexibleContexts). It originally existed to prevent things such as the following:
class C a where c :: a -> a
-- no instance C Int
foo :: C Int => Int
foo = c (5 :: Int)
-- with NoFlexibleContexts: foo's definition is in error
-- with FlexibleContexts: foo is fine; all usages of foo are in error for
-- not providing C Int. This might obscure the source of the problem.
-- slightly more insiduous
data Odd a = Odd a
-- no Eq (Odd a)
oddly (Odd 0) (Odd 0) = False
oddly l r = l == r
-- oddly :: (Num a, Eq (Odd a), Eq a) => Odd a -> Odd a -> Bool
-- Now the weird type is inferred! With FlexibleContexts,
-- the weird constraint can propagate quite far, causing errors in distant
-- places. This is confusing. NoFlexibleContexts places oddly in the spotlight.
But it happens to get in the way a lot when you have MultiParamTypeClasses on.

Modify state using a monadic function with lenses

My question is quite similar to How to modify using a monadic function with lenses? The author asked if something like this exists
overM :: (Monad m) => Lens s t a b -> (a -> m b) -> s -> m t
The answer was mapMOf
mapMOf :: Profunctor p =>
Over p (WrappedMonad m) s t a b -> p a (m b) -> s -> m t
I'm trying to implement a function that modifies state in MonadState using a monadic function:
modifyingM :: MonadState s m => ASetter s s a b -> (a -> m b) -> m ()
Example without modifingM:
{-# LANGUAGE TemplateHaskell #-}
module Main where
import Control.Lens (makeLenses, use, (.=))
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Lazy (StateT(StateT), execStateT)
data GameObject = GameObject
{ _num :: Int
} deriving (Show)
data Game = Game
{ _objects :: [GameObject]
} deriving (Show)
makeLenses ''Game
makeLenses ''GameObject
defaultGame = Game {_objects = map GameObject [0 .. 3]}
action :: StateT Game IO ()
action = do
old <- use objects
new <- lift $ modifyObjects old
objects .= new
modifyObjects :: [GameObject] -> IO [GameObject]
modifyObjects objs = return objs -- do modifications
main :: IO ()
main = do
execStateT action defaultGame
return ()
This example works. Now I'd like to extract the code from action to a generic solution modifingM:
{-# LANGUAGE TemplateHaskell #-}
module Main where
import Control.Lens (makeLenses, use, (.=), ASetter)
import Control.Monad.State.Class (MonadState)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Lazy (StateT(StateT), execStateT)
data GameObject = GameObject
{ _num :: Int
} deriving (Show)
data Game = Game
{ _objects :: [GameObject]
} deriving (Show)
makeLenses ''Game
makeLenses ''GameObject
defaultGame = Game {_objects = map GameObject [0 .. 3]}
modifyingM :: MonadState s m => ASetter s s a b -> (a -> m b) -> m ()
modifyingM l f = do
old <- use l
new <- lift $ f old
l .= new
action :: StateT Game IO ()
action = modifyingM objects modifyObjects
modifyObjects :: [GameObject] -> IO [GameObject]
modifyObjects objs = return objs -- do modifications
main :: IO ()
main = do
execStateT action defaultGame
return ()
This results in compile time errors:
Main.hs:26:14: error:
• Couldn't match type ‘Data.Functor.Identity.Identity s’
with ‘Data.Functor.Const.Const a s’
Expected type: Control.Lens.Getter.Getting a s a
Actual type: ASetter s s a b
• In the first argument of ‘use’, namely ‘l’
In a stmt of a 'do' block: old <- use l
In the expression:
do { old <- use l;
new <- lift $ f old;
l .= new }
• Relevant bindings include
f :: a -> m b (bound at app/Main.hs:25:14)
l :: ASetter s s a b (bound at app/Main.hs:25:12)
modifyingM :: ASetter s s a b -> (a -> m b) -> m ()
(bound at app/Main.hs:25:1)
Main.hs:31:10: error:
• Couldn't match type ‘IO’ with ‘StateT Game IO’
Expected type: StateT Game IO ()
Actual type: IO ()
• In the expression: modifyingM objects modifyObjects
In an equation for ‘action’:
action = modifyingM objects modifyObjects
What's the problem?
Edit 1: Assign new instead of old value.
Edit 2: Added example with solution of #Zeta that does not compile.
Edit 3: Remove example of second edit. It didn't compile due to wrong imports (see comment).
You're using use on a ASetter, but use takes a Getter:
use :: MonadState s m => Getting a s a -> m a
(.=) :: MonadState s m => ASetter s s a b -> b -> m ()
Unfortunately, ASetter and Getting are not the same:
type Getting r s a = (a -> Const r a ) -> s -> Const r s
type ASetter s t a b = (a -> Identity b) -> s -> Identity t
We need to switch between Const and Identity arbitrarily. We need a Lens:
type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
Note that there is no f on the left-hand side. Next, we note that your lift is not necessary. After all, f already works in our target monad m; you had to use lift previously because modifyObjects was in IO and action was in StateT Game IO, but here we just have a single m:
modifyingM :: MonadState s m => Lens s s a a -> (a -> m b) -> m ()
modifyingM l f = do
old <- use l
new <- f old
l .= old
That works! But it's likely wrong, since you probably want to set the new value in l .= old. If that's the case, we have to make sure that old and new have the same type:
-- only a here, no b
-- v v v v
modifyingM :: MonadState s m => Lens s s a a -> (a -> m a) -> m ()
modifyingM l f = do
old <- use l
new <- f old
l .= new
Keep in mind that you need to lift modifyObjects though:
action :: StateT Game IO ()
action = modifyingM objects (lift . modifyObjects)
We could stop here, but just for some fun, let us have a look again at Lens:
type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
For any a -> f b you give me, I'll give you a new s -> f t. So if we just plug something in your objects, we have
> :t \f -> objects f
\f -> objects f
:: Functor f => (GameObject -> f GameObject) -> Game -> f Game
Therefore, we just need some MonadState s m => (s -> m s) -> m () function, but that's easy to achieve:
import Control.Monad.State.Lazy (get, put) -- not the Trans variant!
modifyM :: MonadState s m => (s -> m s) -> m ()
modifyM f = get >>= f >>= put
Note that you need to use Control.Monad.State from mtl instead of Control.Monad.Trans.State. The latter only defines put :: Monad m => s -> StateT s m () and get :: Monad m => StateT s m s, but you want to use the MonadState variant from mtl.
If we put all things together, we see that modifyingM can be written as:
modifyingM :: MonadState s m => Lens s s a a -> (a -> m a) -> m ()
modifyingM l f = modifyM (l f)
Alternatively, we use the can use the lens functions, although that does not give us the insight that we can use l f:
modifyingM :: MonadState s m => Lens s s a a -> (a -> m a) -> m ()
modifyingM l f = use l >>= f >>= assign l

Implementing an MFunctor instance for RVarT

Is it possible to implement an MFunctor instance for RVarT?
So far I've come up with the following:
{-# LANGUAGE RankNTypes #-}
import Data.RVar -- from rvar
import Control.Monad.Trans.Class (lift) -- from transformers
hoistRVarT :: Monad m => (forall t. n t -> m t) -> RVarT n a -> RVarT m a
hoistRVarT f rv = sampleRVarTWith (lift . f) rv
However this can not be used as a definition of hoist for MFunctor, due to the Monad constraint on m incurred by lift. The problem is, that I couldn't find another way to lift the the resulting monad into RVarT without lift. But I think conceptually it should be possible, since RVarT should be similar to StateT and there is an MFunctor instance for StateT. The problem is that I couldn't find anything in the API of rvar or random-fu which exposed such functionality.
RVarT m a is a newtype for PromptT Prim m a, where PromptT is defined in Control.Monad.Prompt. PromptT Prim m a is a newtype for Prompt (Lift Prim m) a. This, in turn, is a newtype for
forall b. (a -> b) -> (forall x. Lift Prim m x -> (x -> b) -> b) -> b
You can unwrap the whole thing with unsafeCoerce:
fromRVarT :: RVarT m a -> (a -> b) -> (forall x. Lift Prim m x -> (x -> b) -> b) -> b
fromRVarT = unsafeCoerce
toRVarT :: (forall b. (a -> b) -> (forall x. Lift Prim m x -> (x -> b) -> b) -> b) -> RVarT m a
toRVarT = unsafeCoerce
Prim isn't exported, but since you shouldn't need to touch it in the first place, and you're assembling and disassembling the whole thing with unsafeCoerce, you can just define:
data Prim a
You can write an MFunctor instance for Lift:
instance MFunctor (Lift f) where
hoist _ (Effect p) = Effect p
hoist phi (Lift m) = Lift (phi m)
And then you can unwrap the RVarT, hoist all the Lifts passed to its prompting function, and wrap it again:
instance MFunctor RVarT where
hoist phi rv = toRVarT $ \done prm -> fromRVarT rv done (\l -> prm $ hoist phi l)
I found a trick that works for this and similar cases if you do not need to be able to actually use a value RVarT m without a monad instance for m. It works by deferring the application of the natural transformation until we actually need to get out a value. It would still be nice if there was a proper instance.
{-# LANGUAGE RankNTypes, ExistentialQuantification #-}
import Data.RVar
import Control.Monad.Trans.Class (lift)
import Control.Monad.Morph
import Control.Monad (ap)
hoistRVarT :: Monad m => (forall t. n t -> m t) -> RVarT n a -> RVarT m a
hoistRVarT f = sampleRVarTWith (lift . f)
data RVarTFun m a = forall n. RVarTFun
{ transformation :: forall t. n t -> m t
, rvart :: RVarT n a }
-- You can only get a value out if you have a monad for m.
getRVarTFun :: Monad m => RVarTFun m a -> RVarT m a
getRVarTFun (RVarTFun t ma) = hoistRVarT t ma
wrapRVarTFun :: RVarT m a -> RVarTFun m a
wrapRVarTFun = RVarTFun id
-- Actually the result is slightly stronger than MFunctor because we don't need
-- a Monad on n.
hoistRVarTFun :: (forall t. n t -> m t) -> RVarTFun n a -> RVarTFun m a
hoistRVarTFun f (RVarTFun t nx) = RVarTFun (f . t) nx
instance MFunctor RVarTFun where
hoist = hoistRVarTFun
A more general implementation of this can be found here.

VTY-UI needs IO. Can I make this happen?

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.

MonadBaseControl: how to lift ThreadGroup

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

Resources