{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}
-- All the above extensions are needed only to define an instance
-- of a MonadState class!
-- Generating chunked stream of random data
-- We demonstrate the pitfall of lazy evaluation and how
-- explicit monadic streams or, better, generators, avoid them.
-- Lazy evaluation doesn't work well with effects, even
-- with effects like State that are implemented in pure Haskell.
-- The example was posted by Dale Jordan on Haskell Cafe on
-- Mon Jan 4 20:31:20 EST 2010.
module Randoms where
import Control.Monad
import Control.Applicative
import System.Random -- Dale Jordan's original example used Mersenne Twister
import Control.Monad.State
import Control.Monad.Reader
-- ------------------------------------------------------------------------
-- The original example posted by Dale Jordan demonstrating the problem
-- The idea is that an action returns a finite list of random values and
-- iterateR lazily creates an infinite list of them, he wrote.
-- The ultimate consumer will pick from that stream as many values as
-- it needs.
-- Our monad, which keeps the state of the random generator
type Rand r = State r
-- A simple example of an action producing a finite list:
-- a list of length n of random numbers uniformly distributed
-- within [m,m+9].
something :: RandomGen g => Int -> Int -> Rand g [Int]
something n m = sequence . replicate n . state $ randomR (m,m+9)
-- Iterate an action and concatenate the resulting finite chunks
-- into an infinite list
iterateR :: RandomGen g => Rand g [Int] -> Rand g [Int]
iterateR m = do
chunk <- m
(chunk ++) <$> iterateR m
-- The ultimate consumer will pick however many elements it needs.
-- In the simplest example, this really works.
run1 = evalState (take 10 <$> (iterateR (something 2 0))) $ mkStdGen 42
-- [1,1,7,4,6,1,8,1,8,5]
-- As we build bigger computations, using bind of the RandR monad,
-- we run into a problem: iterateR really tries to construct
-- an infinite list and quickly runs out of memory.
run2 = evalState
(take 10 <$> (iterateR (something 2 0) >>
iterateR (something 3 10)))
$ mkStdGen 42
-- no answer, out of memory
run3 = evalState
(take 10 <$> (iterateR (something 2 0) >>=
iterateR . (something 3 . head)))
$ mkStdGen 42
-- no answer, out of memory
-- ------------------------------------------------------------------------
-- A solution using explicit streams
-- Explicit monadic stream
data List m a = Nil | Cons a (ListM m a)
type ListM m a = m (List m a)
-- A few operations on Streams
headL :: Monad m => List m e -> e
headL (Cons e _) = e
replicateL :: Monad m => Int -> e -> ListM m e
replicateL 0 _ = return Nil
replicateL n e = return $ Cons e (replicateL (n-1) e)
sequenceL :: Monad m => ListM m (m e) -> ListM m e
sequenceL ml = ml >>= go
where
go Nil = return Nil
go (Cons me t) = me >>= \e -> return $ Cons e (sequenceL t)
appendL :: Monad m => ListM m e -> ListM m e -> ListM m e
appendL l1 l2 = l1 >>= go
where
go Nil = l2
go (Cons e t) = return $ Cons e (appendL t l2)
-- Take a finite number of elements and return the ordinary list, strictly
takeLL :: Monad m => Int -> ListM m e -> m [e]
takeLL 0 _ = return []
takeLL n ml = ml >>= go
where
go Nil = return []
go (Cons e t) = liftM (e:) (takeLL (n-1) t)
-- We re-write the example in terms of ListM
somethingL :: RandomGen g => Int -> Int -> ListM (Rand g) Int
somethingL n m = sequenceL . replicateL n . state $ randomR (m,m+9)
iterateRL :: RandomGen g => ListM (Rand g) Int -> ListM (Rand g) Int
iterateRL m = appendL m (iterateRL m)
run1L = evalState (takeLL 10 (iterateRL (somethingL 2 0))) $ mkStdGen 42
-- [1,1,7,4,6,1,8,1,8,5]
run2L = evalState
(takeLL 10 (iterateRL (somethingL 2 0) >>
iterateRL (somethingL 3 10)))
$ mkStdGen 42
-- [11,17,14,16,11,18,11,18,15,15]
run3L = evalState
(takeLL 10 (iterateRL (somethingL 2 0) >>=
iterateRL . (somethingL 3 . headL)))
$ mkStdGen 42
-- [2,8,5,7,2,9,2,9,6,6]
run11L = evalState (takeLL 10 (iterateRL (somethingL 2 1))) $ mkStdGen 42
-- My original message used a fancier stream, with a known prefix
{-
data RList m a = RList [a] -- known finite prefix
[m [a]] -- a stream of producing actions
-}
-- Dale Jordan characterized that solution as
-- ``solution works by reifying the implicit
-- continuation in my iterateR's recursive definition into a data structure
-- that is explicitly forced with pullR and its callers. ''
-- ------------------------------------------------------------------------
-- A solution using simple generators
-- We repeat the interface of simple generators
type GenT e m = ReaderT (e -> m ()) m -- it is a monad
type Producer m e = GenT e m ()
type Consumer m e = e -> m ()
yield :: Monad m => e -> Producer m e
yield e = ask >>= \f -> lift $ f e
-- Hooking up producers and consumers
runGenT :: Producer m e -> Consumer m e -> m ()
runGenT m f = runReaderT m f
-- Perhaps surprisingly, Producer m e is also a monad, with bindG
-- as given below and yield as return!
-- Since Producer m e is a type alias, we can't easily make
-- it an instance of a Monad class. We have to use newtypes
-- and write wrapping/unwrapping explicitly. It's easier just
-- to use bindG.
bindG :: Monad m => Producer m a -> (a -> Producer m b) -> Producer m b
bindG p f = ask >>= \yf -> lift $ runGenT p (\a -> runGenT (f a) yf)
-- A monad for take. It could be defined in the standard generator
-- library. For clarity, we implement everything from scratch
newtype TakeM e m a =
TakeM{unTakeM :: (Int,[e]) -> m (Either [e] (a,(Int,[e])))}
instance Monad m => Monad (TakeM e m) where
return x = TakeM (\s -> return (Right (x,s)))
TakeM m >>= f = TakeM (\s -> m s >>= check)
where check (Left ls) = return (Left ls)
check (Right ~(x,s)) = unTakeM (f x) s
instance MonadTrans (TakeM e) where
lift m = TakeM (\s -> m >>= \x -> return (Right (x,s)))
instance MonadState s m => MonadState s (TakeM e m) where
get = lift get
put s = lift (put s)
runTakeM :: Monad m => Int -> TakeM e m () -> m [e]
runTakeM n (TakeM m) = liftM (reverse . extract) (m (n,[]))
where
extract (Left x) = x
extract (Right (_,(_,x))) = x
takeG :: Monad m => Int -> Producer (TakeM e m) e -> m [e]
takeG 0 p = return []
takeG n p = runTakeM n (runGenT p go)
where
go e = TakeM (\ (n,acc) ->
return $ if n <= 0 then Left acc else Right ((),(n-1,e:acc)))
-- We re-write Dale Jordan's example in terms of generators
somethingG :: (RandomGen g, MonadState g m) =>
Int -> Int -> Producer m Int
somethingG n m = sequence_ . replicate n .
(>>= yield) . lift . state $ randomR (m,m+9)
iterateRG :: Monad m => Producer m Int -> Producer m Int
iterateRG m = m >> iterateRG m
run1G = evalState (takeG 10 (iterateRG (somethingG 2 0))) $ mkStdGen 42
-- [1,1,7,4,6,1,8,1,8,5]
run2G = evalState
(takeG 10 (iterateRG (somethingG 2 0) `bindG` \_ ->
iterateRG (somethingG 3 10)))
$ mkStdGen 42
-- [11,17,14,16,11,18,11,18,15,15]
-- There is no 'headG' there, and yet it works. Why?
run3G = evalState
(takeG 10 (iterateRG (somethingG 2 0) `bindG`
(iterateRG . (somethingG 3))))
$ mkStdGen 42
-- [2,8,5,7,2,9,2,9,6,6]