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.