Ticket #7428: cont-state8.hs

File cont-state8.hs, 2.4 KB (added by nudded, 17 months ago)
Line 
1{-# LANGUAGE RankNTypes, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, OverlappingInstances#-}
2import Control.Monad (liftM, replicateM)
3import Control.Monad.IO.Class (MonadIO(..))
4import Control.Monad.Trans.Class (MonadTrans(..))
5import Data.IORef
6import Criterion.Main
7
8class Monad m => MonadState s m where
9    get :: m s
10    put :: s -> m ()
11
12modify :: MonadState s m => (s -> s) -> m ()
13modify f = get >>= put . f
14
15newtype StateT s m a = StateT { getStateTFunc
16                                    :: forall r . s -> m ((a -> s -> r) -> r)}
17
18instance Monad m => Monad (StateT s m) where
19    return x = StateT $ \s -> return $ \f -> f x s
20    StateT f >>= g = StateT $ \s -> do
21        useX <- f s
22        useX $ \x s' -> getStateTFunc (g x) s'
23
24instance MonadTrans (StateT s) where
25    lift m = StateT $ \s -> do
26        x <- m
27        return $ \f -> f x s
28
29runStateT :: Monad m => StateT s m a -> s -> m (a, s)
30runStateT f s = do
31    useXS <- getStateTFunc f s
32    return $ useXS $ \x s' -> (x,s')
33
34-- instance (MonadState s m, MonadTrans t, Monad (t m)) => MonadState s (t m) where
35--     get = lift get
36--     put = lift . put
37
38instance Monad m => MonadState s (StateT s m) where
39    get = StateT $ \s -> return $ \f -> f s s
40    put s = s `seq` StateT $ \_ -> return $ \f -> f () s
41
42evalStateT' :: Monad m => s -> StateT s m a -> m a
43evalStateT' s f = liftM fst $ runStateT f s
44
45-- benchmark
46type LargeState = StateT Int (
47                  StateT Int (
48                  StateT Int (
49                  StateT Int (
50                  StateT Int (
51                  StateT Int (
52                  StateT Int (
53                  StateT Int (
54                  StateT Int (
55                  StateT Int (
56                  IO
57                  ))))))))))
58
59incrementLevel0 :: LargeState Int
60incrementLevel0 = do
61    modify inc
62    get
63
64inc :: Int -> Int
65inc n = n + 1
66{-# INLINE inc #-}
67
68runLargeState :: LargeState a -> IO a
69runLargeState s = do
70    let s0 = liftM fst $ runStateT s 0
71    let s1 = liftM fst $ runStateT s0 0
72    let s2 = liftM fst $ runStateT s1 0
73    let s3 = liftM fst $ runStateT s2 0
74    let s4 = liftM fst $ runStateT s3 0
75    let s5 = liftM fst $ runStateT s4 0
76    let s6 = liftM fst $ runStateT s5 0
77    let s7 = liftM fst $ runStateT s6 0
78    let s8 = liftM fst $ runStateT s7 0
79    liftM fst $ runStateT s8 0
80
81main = do
82    s <- runLargeState $ replicateM 1000 incrementLevel0
83    putStrLn $ show s