base: Remove `Monad(fail)` method and reexport `MonadFail(fail)` instead
[ghc.git] / testsuite / tests / perf / compiler / T3064.hs
1 {-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
2 {-# LANGUAGE Rank2Types, TypeSynonymInstances, FlexibleInstances #-}
3 {-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving #-}
4
5 module T3064 where
6 import Control.Applicative
7
8 newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a }
9
10 instance Functor f => Functor (ReaderT r f) where
11 fmap f m = ReaderT $ (fmap f) . runReaderT m
12
13 instance Applicative f => Applicative (ReaderT r f) where
14 pure m = ReaderT (const $ pure m)
15 f <*> v = ReaderT $ \r -> runReaderT f r <*> runReaderT v r
16
17 instance (Monad m) => Monad (ReaderT r m) where
18 return a = ReaderT $ \_ -> return a
19 m >>= k = ReaderT $ \r -> do
20 a <- runReaderT m r
21 runReaderT (k a) r
22
23 instance (MonadFail m) => MonadFail (ReaderT r m) where
24 fail msg = ReaderT $ \_ -> fail msg
25
26 newtype ResourceT r s m v = ResourceT { unResourceT :: ReaderT r m v }
27 deriving (Functor, Applicative, Monad)
28
29 data Ctx = Ctx
30
31 data Ch = Ch
32
33 type CAT s c = ResourceT [Ch] (s,c)
34
35 type CtxM c = ResourceT Ctx c IO
36
37 newtype CA s c v = CA { unCA :: CAT s c (CtxM c) v }
38 deriving (Functor, Applicative, Monad)
39
40 class (Monad m) => MonadCA m where
41 type CtxLabel m
42
43 instance MonadCA (CA s c) where
44 type CtxLabel (CA s c) = c
45
46 instance (Monad m, MonadCA m, c ~ CtxLabel m) => MonadCA (CAT s c m) where
47 type CtxLabel (CAT s c m) = c
48
49 runCAT :: (forall s. CAT s c m v) -> m v
50 runCAT action = runReaderT (unResourceT action) []
51
52 newRgn :: MonadCA m => (forall s. CAT s (CtxLabel m) m v) -> m v
53 newRgn = runCAT
54
55 runCA :: (forall s c. CA s c v) -> IO v
56 runCA action = runCtxM (runCAT (unCA action))
57
58 runCtxM :: (forall c. CtxM c v) -> IO v
59 runCtxM action = runReaderT (unResourceT action) Ctx
60
61 {-
62
63 test4 :: IO ()
64 test4 = runCA(newRgn(newRgn(newRgn(newRgn(return())))))
65
66 test11 :: IO ()
67 test11 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn(
68 newRgn(newRgn(newRgn(newRgn(return()))))))))))
69
70 test12 :: IO ()
71 test12 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
72 newRgn(newRgn(newRgn(newRgn(return())))))))))))
73
74 test13 :: IO ()
75 test13 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
76 newRgn(newRgn(newRgn(newRgn(return()))))))))))))
77
78 test14 :: IO ()
79 test14 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
80 newRgn(newRgn(newRgn(newRgn(return())))))))))))))
81
82 test28 :: IO ()
83 test28 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
84 newRgn(newRgn(newRgn(newRgn(
85 newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
86 newRgn(newRgn(newRgn(newRgn(return())))))))))))))))))))))))))
87 -}
88
89 test56 :: IO ()
90 test56 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
91 newRgn(newRgn(newRgn(newRgn(
92 newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
93 newRgn(newRgn(newRgn(newRgn(
94 newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
95 newRgn(newRgn(newRgn(newRgn(
96 newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
97 newRgn(newRgn(newRgn(newRgn(return())))))))))))))))))))))))))))))))))))))))))))))))))