blob: 3ad183e293219bc55de6468eeb39c4c8c2225f84 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
|
{-# LANGUAGE FlexibleInstances, RankNTypes #-}
module Main ( main, useAbstractMonad ) where
import Control.Monad
import Control.Monad.ST
import Control.Applicative
newtype ReaderT r m a = ReaderT {
-- | The underlying computation, as a function of the environment.
runReaderT :: r -> m a
}
instance (Applicative m) => Applicative (ReaderT r m) where
pure = liftReaderT . pure
f <*> v = ReaderT $ \ r -> runReaderT f r <*> runReaderT v r
instance (Functor m) => Functor (ReaderT r m) where
fmap f = mapReaderT (fmap f)
instance (Monad m) => Monad (ReaderT r m) where
m >>= k = ReaderT $ \ r -> do
a <- runReaderT m r
runReaderT (k a) r
instance MonadFail m => MonadFail (ReaderT r m) where
fail msg = ReaderT (\_ -> fail msg)
mapReaderT :: (m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT f m = ReaderT $ f . runReaderT m
liftReaderT :: m a -> ReaderT r m a
liftReaderT m = ReaderT (const m)
ask :: (Monad m) => ReaderT r m r
ask = ReaderT return
class (Applicative m, Functor m , Monad m) => MonadAbstractIOST m where
addstuff :: Int -> m Int
type ReaderST s = ReaderT (Int) (ST s)
instance MonadAbstractIOST (ReaderST s) where
addstuff a = return . (a +) =<< ask
runAbstractST :: (forall s. ReaderST s a) -> a
runAbstractST f = runST $ runReaderT f 99
{-# SPECIALIZE useAbstractMonad :: Int -> ReaderST s Int #-}
-- Note the polymorphism
useAbstractMonad :: MonadAbstractIOST m => Int -> m Int
useAbstractMonad n = foldM (\a b -> a `seq` return . (a +) =<< (addstuff b)) 0 [1..n]
-- useConcreteMonad :: Int -> ReaderST s Int
-- useConcreteMonad = foldM (\a b -> a `seq` return . (a +) =<< (addstuff b)) 0 [1..n]
main :: IO ()
main = do
let st = runAbstractST (useAbstractMonad 5000000)
putStrLn . show $ st
|
