Reexport Semigroup's <> operator from Prelude (#14191)
[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 as PP
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 -- (a | c); (b | d); e
22 test2 :: M ()
23 test2 = do
24 x1 <- a
25 x3 <- c
26 x2 <- const b x1
27 x4 <- const d x3
28 x5 <- const e (x1,x4)
29 return (const () x5)
30
31 main = mapM_ run
32 [ test1
33 , test2
34 ]
35
36 -- Testing code, prints out the structure of a monad/applicative expression
37
38 newtype M a = M (Bool -> (Maybe Doc, a))
39
40 maybeParen True d = parens d
41 maybeParen _ d = d
42
43 run :: M a -> IO ()
44 run (M m) = print d where (Just d,_) = m False
45
46 instance Functor M where
47 fmap f m = m >>= return . f
48
49 instance Applicative M where
50 pure a = M $ \_ -> (Nothing, a)
51 M f <*> M a = M $ \p ->
52 let (Just d1, f') = f True
53 (Just d2, a') = a True
54 in
55 (Just (maybeParen p (d1 <+> char '|' <+> d2)), f' a')
56
57 instance Monad M where
58 return = pure
59 M m >>= k = M $ \p ->
60 let (d1, a) = m True
61 (d2, b) = case k a of M f -> f True
62 in
63 case (d1,d2) of
64 (Nothing,Nothing) -> (Nothing, b)
65 (Just d, Nothing) -> (Just d, b)
66 (Nothing, Just d) -> (Just d, b)
67 (Just d1, Just d2) -> (Just (maybeParen p (d1 PP.<> semi <+> d2)), b)
68
69 doc :: String -> M ()
70 doc d = M $ \_ -> (Just (text d), ())