aab8d5397f479927c98e3ace38b970efc2c7b6ca
[ghc.git] / testsuite / tests / ado / ado-optimal.hs
1 {-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, ApplicativeDo #-}
2 {-# OPTIONS_GHC -foptimal-applicative-do #-}
3 module Main where
4
5 import Control.Applicative
6 import Text.PrettyPrint
7
8 (a:b:c:d:e:f:g:h:_) = map (\c -> doc [c]) ['a'..]
9
10 -- This one requires -foptimal-applicative-do to find the best solution
11 -- ((a; b) | (c; d)); e
12 test1 :: M ()
13 test1 = do
14 x1 <- a
15 x2 <- const b x1
16 x3 <- c
17 x4 <- const d x3
18 x5 <- const e (x1,x4)
19 return (const () x5)
20
21 main = mapM_ run
22 [ test1
23 ]
24
25 -- Testing code, prints out the structure of a monad/applicative expression
26
27 newtype M a = M (Bool -> (Maybe Doc, a))
28
29 maybeParen True d = parens d
30 maybeParen _ d = d
31
32 run :: M a -> IO ()
33 run (M m) = print d where (Just d,_) = m False
34
35 instance Functor M where
36 fmap f m = m >>= return . f
37
38 instance Applicative M where
39 pure a = M $ \_ -> (Nothing, a)
40 M f <*> M a = M $ \p ->
41 let (Just d1, f') = f True
42 (Just d2, a') = a True
43 in
44 (Just (maybeParen p (d1 <+> char '|' <+> d2)), f' a')
45
46 instance Monad M where
47 return = pure
48 M m >>= k = M $ \p ->
49 let (d1, a) = m True
50 (d2, b) = case k a of M f -> f True
51 in
52 case (d1,d2) of
53 (Nothing,Nothing) -> (Nothing, b)
54 (Just d, Nothing) -> (Just d, b)
55 (Nothing, Just d) -> (Just d, b)
56 (Just d1, Just d2) -> (Just (maybeParen p (d1 <> semi <+> d2)), b)
57
58 doc :: String -> M ()
59 doc d = M $ \_ -> (Just (text d), ())