Ticket #7428: Cont8.2.hs

File Cont8.2.hs, 2.4 KB (added by thoughtpolice, 3 years ago)

AMP compatible test case

Line 
1{-# LANGUAGE RankNTypes            #-}
2{-# LANGUAGE MultiParamTypeClasses #-}
3{-# LANGUAGE FlexibleInstances     #-}
4{-# LANGUAGE FlexibleContexts      #-}
5{-# LANGUAGE OverlappingInstances  #-}
6module Cont8 (main) where
7import Prelude
8
9liftM :: (Monad m) => (a1 -> r) -> m a1 -> m r
10liftM f m1 = do { x1 <- m1; return (f x1) }
11
12ap :: (Monad m) => m (a -> b) -> m a -> m b
13ap m1 m2 = do { x1 <- m1; x2 <- m2; return (x1 x2) }
14
15replicateM :: (Monad m) => Int -> m a -> m [a]
16replicateM n x = sequence (replicate n x)
17
18class Monad m => MonadState s m where
19    get :: m s
20    put :: s -> m ()
21
22modify :: MonadState s m => (s -> s) -> m ()
23modify f = get >>= put . f
24
25newtype StateT s m a = StateT { getStateTFunc
26                                    :: forall r . s -> m ((a -> s -> r) -> r)}
27
28instance Monad m => Functor (StateT s m) where
29    fmap = liftM
30
31instance Monad m => Applicative (StateT s m) where
32    pure = return
33    (<*>) = ap
34
35instance Monad m => Monad (StateT s m) where
36    return x = StateT $ \s -> return $ \f -> f x s
37    StateT f >>= g = StateT $ \s -> do
38        useX <- f s
39        useX $ \x s' -> getStateTFunc (g x) s'
40
41runStateT :: Monad m => StateT s m a -> s -> m (a, s)
42runStateT f s = do
43    useXS <- getStateTFunc f s
44    return $ useXS $ \x s' -> (x,s')
45
46instance Monad m => MonadState s (StateT s m) where
47    get = StateT $ \s -> return $ \f -> f s s
48    put s = s `seq` StateT $ \_ -> return $ \f -> f () s
49
50-- benchmark
51type LargeState = StateT Int (
52                  StateT Int (
53                  StateT Int (
54                  StateT Int (
55                  StateT Int (
56                  StateT Int (
57                  StateT Int (
58                  StateT Int (
59                  StateT Int (
60                  StateT Int (
61                  IO
62                  ))))))))))
63
64incrementLevel0 :: LargeState Int
65incrementLevel0 = do
66    modify inc
67    get
68
69inc :: Int -> Int
70inc n = n + 1
71{-# INLINE inc #-}
72
73runLargeState :: LargeState a -> IO a
74runLargeState s = do
75    let s0 = liftM fst $ runStateT s 0
76    let s1 = liftM fst $ runStateT s0 0
77    let s2 = liftM fst $ runStateT s1 0
78    let s3 = liftM fst $ runStateT s2 0
79    let s4 = liftM fst $ runStateT s3 0
80    let s5 = liftM fst $ runStateT s4 0
81    let s6 = liftM fst $ runStateT s5 0
82    let s7 = liftM fst $ runStateT s6 0
83    let s8 = liftM fst $ runStateT s7 0
84    liftM fst $ runStateT s8 0
85
86main :: IO ()
87main = do
88    s <- runLargeState $ replicateM 1000 incrementLevel0
89    putStrLn $ show s