| 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 |
|---|
