squash StateTs that have the same monoid as state

MS.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

import Control.Applicative
import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Class
import Control.Monad.Morph
import Data.Monoid

newtype MonoidState m a = MonoidState { st :: StateT [Int] m a }
  deriving (Functor, Applicative, Monad, MonadTrans, MFunctor)

instance MMonad MonoidState where
  embed f m = MonoidState $ StateT (\s -> do
    ((a, s1), s2) <- runStateT (st $ f (runStateT (st m) s)) s
    return (a, mappend s2 s1))

foo :: Monad m => MonoidState (MonoidState m) ()
foo = MonoidState $ do put [0,4,7]
                       lift $ MonoidState $ do x <- get
                                               put (9:1:x)
main = do
  s <- execStateT (st $ squash foo) []
  putStrLn (show s)