Hi Chris,

Thank you.  That is exactly what I needed to know.

It's good to know that I'm not totally crazy and that with the
lazier LogT the code can run as it was written.  It seems
as if a request should be made for a Writer.Lazy as well as
the existing Writer.Strict.  (The latter could well be the default,
just as with the ST monad.)  A good idea?

Virtual beer to you sir!

-Greg

On Aug 24, 2006, at 1:05 PM, Chris Kuklewicz wrote:

The problem with WriterT is it is too strict.

See http://www.mail-archive.com/[email protected]/msg16088.html

The fix is adding ~ to the patterns inside the definition of (>>=):

                ~(a,w)  <- runLogT m
                ~(b,w') <- runLogT (k a)

A lazy version of WriterT, called LogT:

{-# OPTIONS_GHC -fglasgow-exts #-}
module Main where
import Control.Monad.ST.Lazy
import Data.STRef.Lazy
import Control.Monad.Writer
import Control.Monad.Identity
import Control.Monad.Fix
import Control.Monad.Trans
import Control.Monad.Reader
import Maybe
import Debug.Trace
type LogMonoid = [String] -> [String]
loopLT :: Int -> LogT [String] Identity [Int]
loopLT 0 = trace "end of loopLT" (return [0])
loopLT x = do
  let msg = "loopLT now "++ show x
  tell [msg]
  liftM (x:) (loopLT (pred x))
newtype LogT w m a = LogT { runLogT :: m (a, w) }
instance (Monad m) => Functor (LogT w m) where
        fmap f m = LogT $ do
                (a, w) <- runLogT m
                return (f a, w)
instance (Monoid w, Monad m) => Monad (LogT w m) where
        return a = LogT $ return (a, mempty)
        m >>= k  = LogT $ do
                ~(a,w)  <- runLogT m
                ~(b,w') <- runLogT (k a)
                return (b, w `mappend` w')
        fail msg = LogT $ fail msg
instance (Monoid w, MonadPlus m) => MonadPlus (LogT w m) where
        mzero       = LogT mzero
        m `mplus` n = LogT $ runLogT m `mplus` runLogT n
instance (Monoid w, MonadFix m) => MonadFix (LogT w m) where
        mfix m = LogT $ mfix $ \ ~(a, _) -> runLogT (m a)
instance (Monoid w, Monad m) => MonadWriter w (LogT w m) where
        tell   w = LogT $ return ((), w)
        listen m = LogT $ do
                (a, w) <- runLogT m
                return ((a, w), w)
        pass   m = LogT $ do
                ((a, f), w) <- runLogT m
                return (a, f w)
instance (Monoid w) => MonadTrans (LogT w) where
        lift m = LogT $ do
                a <- m
                return (a, mempty)
instance (Monoid w, MonadIO m) => MonadIO (LogT w m) where
        liftIO = lift . liftIO
-- This instance needs -fallow-undecidable-instances, because -- it does not satisfy the coverage condition instance (Monoid w, MonadReader r m) => MonadReader r (LogT w m) where
        ask       = lift ask
        local f m = LogT $ local f (runLogT m)
execLogT :: Monad m => LogT w m a -> m w
execLogT m = do
        (_, w) <- runLogT m
        return w
mapLogT :: (m (a, w) -> n (b, w')) -> LogT w m a -> LogT w' n b
mapLogT f m = LogT $ f (runLogT m)
main :: IO ()
main = do
  let logLT = runIdentity (execLogT (loopLT 100))
  print (head logLT)
  print (last logLT)

The output is

 ./maindemo
"loopLT now 100"
end of loopLT
"loopLT now 1"

Just as we want.



_______________________________________________
Haskell-Cafe mailing list
[email protected]
http://www.haskell.org/mailman/listinfo/haskell-cafe

Reply via email to