1 | {-# LANGUAGE RankNTypes, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, OverlappingInstances#-} |
---|
2 | import Control.Monad (liftM, replicateM) |
---|
3 | import Control.Monad.IO.Class (MonadIO(..)) |
---|
4 | import Control.Monad.Trans.Class (MonadTrans(..)) |
---|
5 | import Data.IORef |
---|
6 | import Criterion.Main |
---|
7 | |
---|
8 | class Monad m => MonadState s m where |
---|
9 | get :: m s |
---|
10 | put :: s -> m () |
---|
11 | |
---|
12 | modify :: MonadState s m => (s -> s) -> m () |
---|
13 | modify f = get >>= put . f |
---|
14 | |
---|
15 | newtype StateT s m a = StateT { getStateTFunc |
---|
16 | :: forall r . s -> m ((a -> s -> r) -> r)} |
---|
17 | |
---|
18 | instance 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 | |
---|
24 | instance MonadTrans (StateT s) where |
---|
25 | lift m = StateT $ \s -> do |
---|
26 | x <- m |
---|
27 | return $ \f -> f x s |
---|
28 | |
---|
29 | runStateT :: Monad m => StateT s m a -> s -> m (a, s) |
---|
30 | runStateT 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 | |
---|
38 | instance 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 | |
---|
42 | evalStateT' :: Monad m => s -> StateT s m a -> m a |
---|
43 | evalStateT' s f = liftM fst $ runStateT f s |
---|
44 | |
---|
45 | -- benchmark |
---|
46 | type 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 | |
---|
59 | incrementLevel0 :: LargeState Int |
---|
60 | incrementLevel0 = do |
---|
61 | modify inc |
---|
62 | get |
---|
63 | |
---|
64 | inc :: Int -> Int |
---|
65 | inc n = n + 1 |
---|
66 | {-# INLINE inc #-} |
---|
67 | |
---|
68 | runLargeState :: LargeState a -> IO a |
---|
69 | runLargeState 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 | |
---|
81 | main = do |
---|
82 | s <- runLargeState $ replicateM 1000 incrementLevel0 |
---|
83 | putStrLn $ show s |
---|