3 -- See Trac #1627. The point is that we should get nice
4 -- compact code for Foo
6 -- In GHC 7.0 this fails, and rightly so.
8 module M(foo) where
12 import Data.Array.ST
14 data E' v m a where
15 E :: m a -> E' RValue m a
16 V :: m a -> (a -> m ()) -> E' v m a
18 data LValue
19 data RValue
21 type E m a = E' RValue m a
22 type V m a = E' LValue m a
24 {-# INLINE runE #-}
25 runE :: E' v m a -> m a
26 runE (E t) = t
27 runE (V t _) = t
29 instance Monad m => Functor (E' RValue m) where
30 {-# INLINE fmap #-}
31 fmap f x = liftM f x
33 instance Monad m => Applicative (E' RValue m) where
34 {-# INLINE pure #-}
35 pure x = return x
36 {-# INLINE (<*>) #-}
37 (<*>) = ap
40 {-# INLINE return #-}
41 return x = E \$ return x
42 {-# INLINE (>>=) #-}
43 x >>= f = E \$ do
44 x' <- runE x
45 runE (f x')
47 liftArray :: forall arr m a i . (Ix i, MArray arr a m) =>
48 arr i a -> E m (forall v . [E m i] -> E' v m a)
49 {-# INLINE liftArray #-}
50 liftArray a = E (do
51 let ix :: [E m i] -> m i
52 ix [i] = runE i
53 {-# INLINE f #-}
54 f is = V (ix is >>= readArray a) (\ x -> ix is >>= \ i -> writeArray a i x)
55 return f
56 )
58 {-# INLINE liftE2 #-}
59 liftE2 :: (Monad m) => (a -> b -> c) -> E' va m a -> E' vb m b -> E m c
60 liftE2 op x y = E \$ do
61 x' <- runE x
62 y' <- runE y
63 return (x' `op` y')
65 {-# INLINE plus #-}
66 plus :: (Monad m) => E m Int -> E m Int -> E m Int
67 plus = liftE2 (+)
69 foo :: forall s . STArray s Int Int -> ST s Int
70 foo ma = runE \$ do
71 a <- liftArray ma
72 let one :: E (ST t) Int
73 one = return 1
74 a[one] `plus` a[one]