Ticket #7428: cont-state8-cleaned-up.hs

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