New monads/LazyWriterT

This came up on the mailing list: Why is WriterT never lazy? The answer is it does not use lazy patterns with "~". So here is a more useful NewMonads/LazyWriterT that add two "~" to the definition of (>>=) and renames WriterT to LazyWriterT.

This is very very handy when (Control.Monad.ST.Lazy) is the transformed Monad.

{-# OPTIONS_GHC -fglasgow-exts #-}
module Main where

-- LazyWriterT, copied from http://darcs.haskell.org/packages/mtl/Control/Monad/Writer.hs
import Control.Monad.Writer
import Control.Monad.Reader
import Control.Monad.Fix
import Control.Monad.Trans

newtype LazyWriterT w m a = LazyWriterT { runLazyWriterT :: m (a, w) }

instance (Monad m) => Functor (LazyWriterT w m) where
	fmap f m = LazyWriterT $ do
		(a, w) <- runLazyWriterT m
		return (f a, w)

instance (Monoid w, Monad m) => Monad (LazyWriterT w m) where
	return a = LazyWriterT $ return (a, mempty)
	m >>= k  = LazyWriterT $ do
		~(a,w)  <- runLazyWriterT m
		~(b,w') <- runLazyWriterT (k a)
		return (b, w `mappend` w')
	fail msg = LazyWriterT $ fail msg

instance (Monoid w, MonadPlus m) => MonadPlus (LazyWriterT w m) where
	mzero       = LazyWriterT mzero
	m `mplus` n = LazyWriterT $ runLazyWriterT m `mplus` runLazyWriterT n

instance (Monoid w, MonadFix m) => MonadFix (LazyWriterT w m) where
	mfix m = LazyWriterT $ mfix $ \ ~(a, _) -> runLazyWriterT (m a)

instance (Monoid w, Monad m) => MonadWriter w (LazyWriterT w m) where
	tell   w = LazyWriterT $ return ((), w)
	listen m = LazyWriterT $ do
		(a, w) <- runLazyWriterT m
		return ((a, w), w)
	pass   m = LazyWriterT $ do
		((a, f), w) <- runLazyWriterT m
		return (a, f w)

instance (Monoid w) => MonadTrans (LazyWriterT w) where
	lift m = LazyWriterT $ do
		a <- m
		return (a, mempty)

instance (Monoid w, MonadIO m) => MonadIO (LazyWriterT w m) where
	liftIO = lift . liftIO

instance (Monoid w, MonadReader r m) => MonadReader r (LazyWriterT w m) where
	ask       = lift ask
	local f m = LazyWriterT $ local f (runLazyWriterT m)


execLazyWriterT :: Monad m => LazyWriterT w m a -> m w
execLazyWriterT m = do
	(_, w) <- runLazyWriterT m
	return w

mapLazyWriterT :: (m (a, w) -> n (b, w')) -> LazyWriterT w m a -> LazyWriterT w' n b
mapLazyWriterT f m = LazyWriterT $ f (runLazyWriterT m)