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.
_______________________________________________
Haskell-Cafe mailing list
Haskell-Cafe@haskell.org
http://www.haskell.org/mailman/listinfo/haskell-cafe
