第30回　状態を扱う複数のモナドを合成したRWSモナド

newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) }

evalRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (a, w)
evalRWST m r s = do
    ~(a, _, w) <- runRWST m r s
    return (a, w)

execRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (s, w)
execRWST m r s = do
    ~(_, s', w) <- runRWST m r s
    return (s', w)

mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
mapRWST f m = RWST $ \r s -> f (runRWST m r s)

withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a
withRWST f m = RWST $ \r s -> uncurry (runRWST m) (f r s)

instance (Monad m) => Functor (RWST r w s m) where
    fmap f m = RWST $ \r s -> do
        ~(a, s', w) <- runRWST m r s
        return (f a, s', w)

instance (Monoid w, Monad m) => Monad (RWST r w s m) where
    return a = RWST $ \_ s -> return (a, s, mempty)
    m >>= k  = RWST $ \r s -> do
        ~(a, s', w)  <- runRWST m r s
        ~(b, s'',w') <- runRWST (k a) r s'
        return (b, s'', w `mappend` w')
    fail msg = RWST $ \_ _ -> fail msg

instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where
    mzero       = RWST $ \_ _ -> mzero
    m `mplus` n = RWST $ \r s -> runRWST m r s `mplus` runRWST n r s

～ 略 ～

instance (Monoid w, Monad m) => MonadReader r (RWST r w s m) where
    ask       = RWST $ \r s -> return (r, s, mempty)
    local f m = RWST $ \r s -> runRWST m (f r) s

instance (Monoid w, Monad m) => MonadWriter w (RWST r w s m) where
    tell   w = RWST $ \_ s -> return ((),s,w)
    listen m = RWST $ \r s -> do
        ~(a, s', w) <- runRWST m r s
        return ((a, w), s', w)
    pass   m = RWST $ \r s -> do
        ~((a, f), s', w) <- runRWST m r s
        return (a, s', f w)

instance (Monoid w, Monad m) => MonadState s (RWST r w s m) where
    get   = RWST $ \_ s -> return (s, s, mempty)
    put s = RWST $ \_ _ -> return ((), s, mempty)

instance (Monoid w, Monad m) => MonadRWS r w s (RWST r w s m)

-- ---------------------------------------------------------------------------
-- Instances for other mtl transformers

instance (Monoid w) => MonadTrans (RWST r w s) where
    lift m = RWST $ \_ s -> do
        a <- m
        return (a, s, mempty)

instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where
    liftIO = lift . liftIO

Prelude Control.Monad.RWS> runRWST (ask >>= tell) "group" 0
((),0,"group")
Prelude Control.Monad.RWS> runRWST (local ("semi-" ++) ask >>= tell) "group" 0
((),0,"semi-group")
Prelude Control.Monad.RWS> runRWST (withRWST (\_ s -> ("category", s)) ask >>= tell) "group" 0
((),0,"category")
Prelude Control.Monad.RWS> runRWST (listen $ ask >>= tell) "group" 0
(((),"group"),0,"group")
Prelude Control.Monad.RWS> runRWST (listens ("semi-" ++) $ ask >>= tell) "group" 0
(((),"semi-group"),0,"group")
Prelude Control.Monad.RWS> runRWST (censor ("semi-" ++) $ ask >>= tell) "group" 0
((),0,"semi-group")
Prelude Control.Monad.RWS> runRWST (get >>= tell) "group" (Any False)
((),Any {getAny = False},Any {getAny = False})
Prelude Control.Monad.RWS> runRWST (get >>= tell >> tell (Any True)) "group" (Any False)
((),Any {getAny = False},Any {getAny = True})
Prelude Control.Monad.RWS> runRWST (get >>= tell >> put (Any True)) "group" (Any False)
((),Any {getAny = True},Any {getAny = False})
Prelude Control.Monad.RWS> runRWST (get >>= tell >> (liftIO . print) 0) "group" "category"
0
((),"category","category")
Prelude Control.Monad.RWS> evalRWST (get >>= tell >> (liftIO . print) 0) "group" "category"
0
((),"category")
Prelude Control.Monad.RWS> execRWST (get >>= tell >> (liftIO . print) 0) "group" "category"
0
("category","category")