Ticket #3064: Bug2.hs

File Bug2.hs, 1.6 KB (added by simonpj, 9 years ago)

Bug file showing long compile times

Line 
1{-# LANGUAGE Rank2Types, TypeSynonymInstances #-}
2{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving #-}
3module Bug2 where
4
5import Control.Monad.Reader
6
7newtype ResourceT r s m v = ResourceT { unResourceT :: ReaderT r m v }
8  deriving (Monad)
9
10data Ctx = Ctx
11
12data Ch = Ch
13
14type CAT s c = ResourceT [Ch] (s,c)
15
16type CtxM c = ResourceT Ctx c IO
17
18newtype CA s c v = CA { unCA :: CAT s c (CtxM c) v }
19  deriving (Monad)
20
21class (Monad m) => MonadCA m where
22  type CtxLabel m
23
24instance MonadCA (CA s c) where
25  type CtxLabel (CA s c) = c
26
27instance (Monad m, MonadCA m, c ~ CtxLabel m) => MonadCA  (CAT s c m) where
28  type CtxLabel (CAT s c m) = c
29
30runCAT :: (forall s. CAT s c m v) -> m v
31runCAT action = runReaderT (unResourceT action) []
32
33newRgn :: MonadCA m => (forall s. CAT s (CtxLabel m) m v) -> m v
34newRgn = runCAT
35
36runCA :: (forall s c. CA s c v) -> IO v
37runCA action = runCtxM (runCAT (unCA action))
38
39runCtxM :: (forall c. CtxM c v) -> IO v
40runCtxM action = runReaderT (unResourceT action) Ctx
41
42test11 :: IO ()
43test11 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn(
44  newRgn(newRgn(newRgn(newRgn(return()))))))))))
45
46-- test12 :: IO ()
47-- test12 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
48--   newRgn(newRgn(newRgn(newRgn(return())))))))))))
49
50-- test13 :: IO ()
51-- test13 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
52--   newRgn(newRgn(newRgn(newRgn(return()))))))))))))
53
54-- test14 :: IO ()
55-- test14 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
56--   newRgn(newRgn(newRgn(newRgn(return())))))))))))))
57