Major patch to add -fwarn-redundant-constraints
[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 fail msg = ReaderT $ \_ -> fail msg
23
24 newtype ResourceT r s m v = ResourceT { unResourceT :: ReaderT r m v }
25 deriving (Functor, Applicative, Monad)
26
27 data Ctx = Ctx
28
29 data Ch = Ch
30
31 type CAT s c = ResourceT [Ch] (s,c)
32
33 type CtxM c = ResourceT Ctx c IO
34
35 newtype CA s c v = CA { unCA :: CAT s c (CtxM c) v }
36 deriving (Functor, Applicative, Monad)
37
38 class (Monad m) => MonadCA m where
39 type CtxLabel m
40
41 instance MonadCA (CA s c) where
42 type CtxLabel (CA s c) = c
43
44 instance (Monad m, MonadCA m, c ~ CtxLabel m) => MonadCA (CAT s c m) where
45 type CtxLabel (CAT s c m) = c
46
47 runCAT :: (forall s. CAT s c m v) -> m v
48 runCAT action = runReaderT (unResourceT action) []
49
50 newRgn :: MonadCA m => (forall s. CAT s (CtxLabel m) m v) -> m v
51 newRgn = runCAT
52
53 runCA :: (forall s c. CA s c v) -> IO v
54 runCA action = runCtxM (runCAT (unCA action))
55
56 runCtxM :: (forall c. CtxM c v) -> IO v
57 runCtxM action = runReaderT (unResourceT action) Ctx
58
59 -- test11 :: IO ()
60 -- test11 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn(
61 -- newRgn(newRgn(newRgn(newRgn(return()))))))))))
62
63 -- test12 :: IO ()
64 -- test12 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
65 -- newRgn(newRgn(newRgn(newRgn(return())))))))))))
66
67 -- test13 :: IO ()
68 -- test13 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
69 -- newRgn(newRgn(newRgn(newRgn(return()))))))))))))
70
71
72 {-
73 test14 :: IO ()
74 test14 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
75 newRgn(newRgn(newRgn(newRgn(return())))))))))))))
76
77 test28 :: IO ()
78 test28 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
79 newRgn(newRgn(newRgn(newRgn(
80 newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
81 newRgn(newRgn(newRgn(newRgn(return())))))))))))))))))))))))))
82 -}
83
84 test56 :: IO ()
85 test56 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
86 newRgn(newRgn(newRgn(newRgn(
87 newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
88 newRgn(newRgn(newRgn(newRgn(
89 newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
90 newRgn(newRgn(newRgn(newRgn(
91 newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
92 newRgn(newRgn(newRgn(newRgn(return())))))))))))))))))))))))))))))))))))))))))))))))))