[Haskell-cafe] style question: Writer monad or unsafeIOToST?

[Chris Kuklewicz]

So using LogT instead of WriterT, and changing from Control.Monad.ST to 
Control.Monad.ST.Lazy I can make you code work as you wanted:

> {-# OPTIONS_GHC -fglasgow-exts #-}
> module Main where
> 
> import Control.Monad.ST.Lazy
> import Data.STRef.Lazy
> import Maybe
> import Debug.Trace
> -- LogT, 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 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
> 
> 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)
> 
> -- End of LogT
> 
> 
> data TagState = Syncing | Listening | Sleeping
>                 deriving (Eq, Show)
> 
> 
> -- A type for combined logging and state transformation:
> -- 
> type LogMonoid = [String] -> [String]
> type LogST s a = LogT LogMonoid (ST s) a
> 
> 
> -- A structure with internal state:
> -- 
> data Tag s = Tag {
>         tagID :: ! Int,
>         state :: ! (STRef s TagState),
>         count :: ! (STRef s Integer)
> }
> 
> 
> data FrozenTag = FrozenTag {
>         ft_tagID :: Int,
>         ft_state :: TagState,
>         ft_count :: Integer
> } deriving Show
> 
> 
> 
> -- Repeat a computation until it returns Nothing:
> -- 
> until_ :: Monad m => m (Maybe a) -> m ()
> until_ action = do
>         result <- action
>         if isNothing result
>            then trace "until_ is finished" (return ())
>            else until_ action
> 
> 
> -- Here is a toy stateful computation:
> -- 
> runTag :: LogST s (FrozenTag)
> runTag = do
>         tag <- initialize
>         until_ (step tag)
>         freezeTag tag
> 
> 
> initialize :: LogST s (Tag s)
> initialize = do
>         init_count <- lift $ newSTRef 1000000
>         init_state <- lift $ newSTRef Syncing
> 
>         return (Tag { tagID = 1,
>                       state = init_state,
>                       count = init_count })
> 
> 
> step :: Tag s -> LogST s (Maybe Integer)
> step t = do
>         c <- lift $ readSTRef (count t)
>         s <- lift $ readSTRef (state t)
>         lift $ writeSTRef (count t) $! (c - 1)
>         lift $ writeSTRef (state t) $! (nextState s)
>         tell (("next state is " ++ show s) : )
>         if (c <= 0) then return Nothing else return (Just c)
> 
> 
> nextState :: TagState -> TagState
> nextState s = case s of
>         Syncing   -> Listening
>         Listening -> Sleeping
>         Sleeping  -> Syncing
> 
> 
> freezeTag :: Tag s -> LogST s (FrozenTag)
> freezeTag t = do
>         frozen_count <- lift $ readSTRef (count t)
>         frozen_state <- lift $ readSTRef (state t)
> 
>         return (FrozenTag { ft_tagID = tagID t,
>                             ft_count = frozen_count,
>                             ft_state = frozen_state })
> 
> 
> main :: IO ()
> main = do
>         let (t, l) = runST (runLogT runTag)
>             log = l []
>         putStrLn (show . head $ log)
>         putStrLn (show . last $ log)

output is

$ ./main2
"next state is Syncing"
until_ is finished
"next state is Listening"

with a very long delay after the first line of output and before the second.