Merge branch 'master' into atomics
[ghc.git] / testsuite / tests / simplCore / should_compile / simpl017.hs
1 {-# OPTIONS -XImpredicativeTypes -fno-warn-deprecated-flags -XEmptyDataDecls -XGADTs -XLiberalTypeSynonyms -XFlexibleInstances -XScopedTypeVariables #-}
2
3 -- See Trac #1627. The point is that we should get nice
4 -- compact code for Foo
5
6 -- In GHC 7.0 this fails, and rightly so.
7
8 module M(foo) where
9
10 import Control.Monad.ST
11 import Data.Array.ST
12
13 data E' v m a where
14 E :: m a -> E' RValue m a
15 V :: m a -> (a -> m ()) -> E' v m a
16
17 data LValue
18 data RValue
19
20 type E m a = E' RValue m a
21 type V m a = E' LValue m a
22
23 {-# INLINE runE #-}
24 runE :: E' v m a -> m a
25 runE (E t) = t
26 runE (V t _) = t
27
28 instance (Monad m) => Monad (E' RValue m) where
29 {-# INLINE return #-}
30 return x = E $ return x
31 {-# INLINE (>>=) #-}
32 x >>= f = E $ do
33 x' <- runE x
34 runE (f x')
35
36 liftArray :: forall arr m a i . (Ix i, MArray arr a m) =>
37 arr i a -> E m (forall v . [E m i] -> E' v m a)
38 {-# INLINE liftArray #-}
39 liftArray a = E (do
40 let ix :: [E m i] -> m i
41 ix [i] = runE i
42 {-# INLINE f #-}
43 f is = V (ix is >>= readArray a) (\ x -> ix is >>= \ i -> writeArray a i x)
44 return f
45 )
46
47 {-# INLINE liftE2 #-}
48 liftE2 :: (Monad m) => (a -> b -> c) -> E' va m a -> E' vb m b -> E m c
49 liftE2 op x y = E $ do
50 x' <- runE x
51 y' <- runE y
52 return (x' `op` y')
53
54 {-# INLINE plus #-}
55 plus :: (Monad m) => E m Int -> E m Int -> E m Int
56 plus = liftE2 (+)
57
58 foo :: forall s . STArray s Int Int -> ST s Int
59 foo ma = runE $ do
60 a <- liftArray ma
61 let one :: E (ST t) Int
62 one = return 1
63 a[one] `plus` a[one]
64