T3064.hs 3.04 KB
Newer Older
1
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
2
{-# LANGUAGE Rank2Types, TypeSynonymInstances, FlexibleInstances #-}
Ian Lynagh's avatar
Ian Lynagh committed
3
{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving #-}
4

5
module T3064 where
Austin Seipp's avatar
Austin Seipp committed
6
import Control.Applicative
Ian Lynagh's avatar
Ian Lynagh committed
7
8
9

newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a }

Austin Seipp's avatar
Austin Seipp committed
10
11
12
13
14
15
16
instance Functor f => Functor (ReaderT r f) where
  fmap f m = ReaderT $ (fmap f) . runReaderT m

instance Applicative f => Applicative (ReaderT r f) where
  pure m   = ReaderT (const $ pure m)
  f <*> v = ReaderT $ \r -> runReaderT f r <*> runReaderT v r

Ian Lynagh's avatar
Ian Lynagh committed
17
18
19
20
21
22
23
24
instance (Monad m) => Monad (ReaderT r m) where
    return a = ReaderT $ \_ -> return a
    m >>= k  = ReaderT $ \r -> do
        a <- runReaderT m r
        runReaderT (k a) r
    fail msg = ReaderT $ \_ -> fail msg

newtype ResourceT r s m v = ResourceT { unResourceT :: ReaderT r m v }
Austin Seipp's avatar
Austin Seipp committed
25
  deriving (Functor, Applicative, Monad)
Ian Lynagh's avatar
Ian Lynagh committed
26
27
28
29
30
31
32
33
34
35

data Ctx = Ctx

data Ch = Ch

type CAT s c = ResourceT [Ch] (s,c)

type CtxM c = ResourceT Ctx c IO

newtype CA s c v = CA { unCA :: CAT s c (CtxM c) v }
Austin Seipp's avatar
Austin Seipp committed
36
  deriving (Functor, Applicative, Monad)
Ian Lynagh's avatar
Ian Lynagh committed
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58

class (Monad m) => MonadCA m where
  type CtxLabel m

instance MonadCA (CA s c) where
  type CtxLabel (CA s c) = c

instance (Monad m, MonadCA m, c ~ CtxLabel m) => MonadCA  (CAT s c m) where
  type CtxLabel (CAT s c m) = c

runCAT :: (forall s. CAT s c m v) -> m v
runCAT action = runReaderT (unResourceT action) []

newRgn :: MonadCA m => (forall s. CAT s (CtxLabel m) m v) -> m v
newRgn = runCAT

runCA :: (forall s c. CA s c v) -> IO v
runCA action = runCtxM (runCAT (unCA action))

runCtxM :: (forall c. CtxM c v) -> IO v
runCtxM action = runReaderT (unResourceT action) Ctx

59
{-
Ian Lynagh's avatar
Ian Lynagh committed
60

61
62
test4 :: IO ()
test4 = runCA(newRgn(newRgn(newRgn(newRgn(return())))))
Ian Lynagh's avatar
Ian Lynagh committed
63

64
65
66
test11 :: IO ()
test11 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn(
               newRgn(newRgn(newRgn(newRgn(return()))))))))))
Ian Lynagh's avatar
Ian Lynagh committed
67

68
69
70
71
72
73
74
test12 :: IO ()
test12 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
               newRgn(newRgn(newRgn(newRgn(return())))))))))))

test13 :: IO ()
test13 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
               newRgn(newRgn(newRgn(newRgn(return()))))))))))))
75

Ian Lynagh's avatar
Ian Lynagh committed
76
77
test14 :: IO ()
test14 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
78
79
80
81
82
83
84
               newRgn(newRgn(newRgn(newRgn(return())))))))))))))

test28 :: IO ()
test28 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
               newRgn(newRgn(newRgn(newRgn(
               newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
               newRgn(newRgn(newRgn(newRgn(return())))))))))))))))))))))))))
85
-}
86
87
88
89
90
91
92
93
94
95

test56 :: IO ()
test56 = runCA(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
               newRgn(newRgn(newRgn(newRgn(
               newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
               newRgn(newRgn(newRgn(newRgn(
               newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
               newRgn(newRgn(newRgn(newRgn(
               newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(newRgn(
               newRgn(newRgn(newRgn(newRgn(return())))))))))))))))))))))))))))))))))))))))))))))))))