I wrote a monad with Writer functionality, using the Operational Monad approach. Then I noticed it does not work lazily.
In the code below, there is a rogueWriter
that performs infinitely many statements that each write a string. The program does not terminate althaugh only some characters of the infinite output are required.
After my analysis I noticed the rogue writer is actually quite friendly (haha) because when I change from runMyWriter rogueWriter
to runWriter rogueWriter
, everything goes well.
SomeMonadT
arise the same problem inSomeMonadT Writer w
resp. WriterT w SomeMonad
(perhaps some examples?)Edit: Is it possible that I'm trying to reverse an infinite string here? A striking difference between Sjoerd Visscher's solution and mine is
w `mappend` ws resp. ws `mappend` w
{-# LANGUAGE GADTs, FlexibleContexts, TypeSynonymInstances,
FlexibleInstances, MultiParamTypeClasses #-}
module Writer where
import Control.Monad.Identity
import Control.Monad.Operational
import Control.Monad.Writer
import Data.Monoid
data MyWriterI w a where
Tell :: w -> MyWriterI w ()
type MyWriterT w = ProgramT (MyWriterI w)
type MyWriter w = (MyWriterT w) Identity
runMyWriterT :: (Monad m, Monoid w) => MyWriterT w m a -> m (a, w)
runMyWriterT prog = run prog mempty
where
run prog ws = viewT prog >>= flip eval ws
eval (Return a) ws = return (a, ws)
eval (Tell w :>>= is) ws = run (is ()) (ws `mappend` w)
runMyWriter :: (Monoid w) => MyWriter w a -> (a, w)
runMyWriter prog = runIdentity (runMyWriterT prog)
instance (Monad m, Monoid w) => MonadWriter w (MyWriterT w m) where
tell = singleton . Tell
listen = undefined
pass = undefined
-- Demonstration of the problem:
rogueWriter :: MonadWriter String m => m ()
rogueWriter = mapM_ (tell . show) [1..]
main = let (_, infiniteOutput) = runMyWriter rogueWriter
in putStrLn (take 20 infiniteOutput)
I don't know exactly why your program fails, but this is how I would write it:
runMyWriterT prog = run prog
where
run prog = viewT prog >>= eval
eval (Return a) = return (a, mempty)
eval (Tell w :>>= is) = do
~(r, ws) <- run (is ())
return (r, w `mappend` ws)