Make Applicative a superclass of Monad
[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
11 import Control.Monad.ST
12 import Data.Array.ST
13
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
17
18 data LValue
19 data RValue
20
21 type E m a = E' RValue m a
22 type V m a = E' LValue m a
23
24 {-# INLINE runE #-}
25 runE :: E' v m a -> m a
26 runE (E t) = t
27 runE (V t _) = t
28
29 instance Monad m => Functor (E' RValue m) where
30 {-# INLINE fmap #-}
31 fmap f x = liftM f x
32
33 instance Monad m => Applicative (E' RValue m) where
34 {-# INLINE pure #-}
35 pure x = return x
36 {-# INLINE (<*>) #-}
37 (<*>) = ap
38
39 instance (Monad m) => Monad (E' RValue m) where
40 {-# INLINE return #-}
41 return x = E $ return x
42 {-# INLINE (>>=) #-}
43 x >>= f = E $ do
44 x' <- runE x
45 runE (f x')
46
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 )
57
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')
64
65 {-# INLINE plus #-}
66 plus :: (Monad m) => E m Int -> E m Int -> E m Int
67 plus = liftE2 (+)
68
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]
75