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