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

[Gregory Wright]

Hi,

Thanks to the responses earlier from the list, the core of my simulator
now happy processes tens of millions of state updates without running
out of stack.

The goal of the simulator is to produce a log of tag states, which  
can be
analyzed to find statistics of how often the sensor tags in a  
particular state.
(In the toy model below there is no external signal, so the log isn't  
very
interesting yet.)  For the moment, I am using the "big stick"  
approach of
unsafeIOToST to write log messages.  Since the only outputs of the  
program
are the log messages, and invocations of "step" are ordered by the ST  
monad,
it seems that unsafeIOToST is safe in this case, in the sense that  
the outputs
will all be ordered the same as the actual state updates.

I've tested the program test1.hs below and it quite fast (runs in  
just under 10 s,
or about 10^6 state updates per second).

I've considered using a WriterT monad to wrap the ST monad to produce
a log.  The problem with this seems to be ensuring that the log output
is generated lazily so it can be incrementally output. A somewhat broken
sketch is the program test2.hs below.  I used a function from  
[String] -> [String]
as the monoid to avoid the O(n^2) inefficiency of appending to a  
list, but
my implementation of this may well be faulty.

To my eye, the Writer monad should be a better way, since it  
encapsulates
the logging process, separating it from other I/O that the program  
may do.
On the other hand, I don't see an easy way to ensure that the log output
is generated lazily so that it can be output incrementally.  I think  
that the
main issue is that until_ is building up a list of log strings, but  
that these
aren't passed to the putStrLn until after the completion of the whole  
runTag
function.  ATM, running test2 gives a stack overflow.

Could someone point out how the Writer monad could be adapted to this,
or tell me that,  "Real programmers just use unsafe* and get on with  
it" ?

Best,
greg


------------------------------------------------------------------------ 
------------------------------

test1.hs, the big stick (unsafeIOToST):

--
-- test1.hs, state updating with logging via unsafeIOToST.
--


module Main where


import Control.Monad.ST
import Data.STRef
import Maybe


data TagState = Syncing | Listening | Sleeping
                 deriving (Eq, Show)


-- 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 return ()
            else until_ action


-- Here is a toy stateful computation:
--
runTag :: ST s (FrozenTag)
runTag = do
         tag <- initialize
         until_ (step tag)
         freezeTag tag


initialize :: ST s (Tag s)
initialize = do
         init_count <- newSTRef 1000000
         init_state <- newSTRef Syncing

         return (Tag { tagID = 1,
                       state = init_state,
                       count = init_count })


step :: Tag s -> ST s (Maybe Integer)
step t = do
         c <- readSTRef (count t)
         s <- readSTRef (state t)
         writeSTRef (count t) $! (c - 1)
         writeSTRef (state t) $! (nextState s)
         unsafeIOToST $! putStrLn ("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 -> ST s (FrozenTag)
freezeTag t = do
         frozen_count <- readSTRef (count t)
         frozen_state <- readSTRef (state t)

         return (FrozenTag { ft_tagID = tagID t,
                             ft_count = frozen_count,
                             ft_state = frozen_state })


main :: IO ()
main = do
         print $ runST (runTag)






------------------------------------------------------------------------ 
-----------------------------------------

test2.hs: stacked WriterT and ST monads:

--
-- test2.hs, state updating with logging via the WriterT monad.
--


module Main where


import Control.Monad.ST
import Control.Monad.Writer
import Data.STRef
import Maybe


data TagState = Syncing | Listening | Sleeping
                 deriving (Eq, Show)


-- A type for combined logging and state transformation:
--
type LogMonoid = [String] -> [String]
type LogST s a = WriterT 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 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 (runWriterT runTag)
         putStrLn (show t)
         putStrLn (unlines (l []))