Ticket #1627: Inl.hs

File Inl.hs, 1.3 KB (added by guest, 8 years ago)
Line 
1{-# OPTIONS_GHC -fglasgow-exts #-}
2module M(foo) where
3
4import Control.Monad.ST
5import Data.Array.ST
6
7data E' v m a where
8    E :: m a -> E' RValue m a
9    V :: m a -> (a -> m ()) -> E' v m a
10
11data LValue
12data RValue
13
14type E m a = E' RValue m a
15type V m a = E' LValue m a
16
17{-# INLINE runE #-}
18runE :: E' v m a -> m a
19runE (E t) = t
20runE (V t _) = t
21
22instance (Monad m) => Monad (E' RValue m) where
23    {-# INLINE return #-}
24    return x = E $ return x
25    {-# INLINE (>>=) #-}
26    x >>= f = E $ do
27        x' <- runE x
28        runE (f x')
29
30liftArray :: forall arr m a i . (Ix i, MArray arr a m) =>
31             arr i a -> E m (forall v . [E m i] -> E' v m a)
32{-# INLINE liftArray #-}
33liftArray a = E (do
34    let ix :: [E m i] -> m i
35        ix [i] = runE i
36        {-# INLINE f #-}
37        f is = V (ix is >>= readArray a) (\ x -> ix is >>= \ i -> writeArray a i x)
38    return f
39  )
40
41{-# INLINE liftE2 #-}
42liftE2 :: (Monad m) => (a -> b -> c) -> E' va m a -> E' vb m b -> E m c
43liftE2 op x y = E $ do
44    x' <- runE x
45    y' <- runE y
46    return (x' `op` y')
47
48{-# INLINE plus #-}
49plus :: (Monad m) => E m Int -> E m Int -> E m Int
50plus = liftE2 (+)
51
52foo :: forall s . STArray s Int Int -> ST s Int
53foo ma = runE $ do
54    a <- liftArray ma
55    let one :: E (ST s) Int
56        one = return 1
57    a[one] `plus` a[one]
58