Reexport Semigroup's <> operator from Prelude (#14191)
[ghc.git] / testsuite / tests / ado / ado001.hs
1 {-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, ApplicativeDo #-}
2 module Main where
3
4 import Control.Applicative
5 import Text.PrettyPrint as PP
6
7 (a:b:c:d:e:f:g:h:_) = map (\c -> doc [c]) ['a'..]
8
9 -- a | b
10 test1 :: M ()
11 test1 = do
12 x1 <- a
13 x2 <- b
14 const (return ()) (x1,x2)
15
16 -- no parallelism
17 test2 :: M ()
18 test2 = do
19 x1 <- a
20 x2 <- const g x1
21 const (return ()) (x1,x2)
22
23 -- a | (b;g) | e
24 test3 :: M ()
25 test3 = do
26 x1 <- a
27 x2 <- b
28 x3 <- const g x2
29 x4 <- e
30 return () `const` (x1,x2,x3,x4)
31
32 -- (a ; (b | g)) | c
33 -- or
34 -- ((a | b); g) | c
35 test4 :: M ()
36 test4 = do
37 x1 <- a
38 x2 <- b
39 x3 <- const g x1
40 x4 <- c
41 return () `const` (x2,x3,x4)
42
43 -- (a | b | c); (g | h)
44 test5 :: M ()
45 test5 = do
46 x1 <- a
47 x2 <- b
48 x3 <- c
49 x4 <- const g x1
50 x5 <- const h x3
51 return () `const` (x3,x4,x5)
52
53 -- b/c in parallel, e/f in parallel
54 -- a; (b | (c; (d; (e | (f; g)))))
55 test6 :: M ()
56 test6 = do
57 x1 <- a
58 x2 <- const b x1
59 x3 <- const c x1
60 x4 <- const d x3
61 x5 <- const e x4
62 x6 <- const f x4
63 x7 <- const g x6
64 return () `const` (x1,x2,x3,x4,x5,x6,x7)
65
66 -- (a | b); (c | d)
67 test7 :: M ()
68 test7 = do
69 x1 <- a
70 x2 <- b
71 x3 <- const c x1
72 x4 <- const d x2
73 return () `const` (x3,x4)
74
75 -- a; (b | c | d)
76 --
77 -- alternative (but less good):
78 -- ((a;b) | c); d
79 test8 :: M ()
80 test8 = do
81 x1 <- a
82 x2 <- const b x1
83 x3 <- c
84 x4 <- const d x1
85 return () `const` (x2,x3,x4)
86
87 -- test that Lets don't get in the way
88 -- ((a | (b; c)) | d) | e
89 test9 :: M ()
90 test9 = do
91 x1 <- a
92 let x = doc "x" -- this shouldn't get in the way of grouping a/b
93 x2 <- b
94 x3 <- const c x2
95 x4 <- d
96 x5 <- e
97 let y = doc "y"
98 return ()
99
100 -- ((a | b) ; (c | d)) | e
101 test10 :: M ()
102 test10 = do
103 x1 <- a
104 x2 <- b
105 let z1 = (x1,x2)
106 x3 <- const c x1
107 let z2 = (x1,x2)
108 x4 <- const d z1
109 x5 <- e
110 return (const () (x3,x4,x5))
111
112 -- (a | b)
113 -- This demonstrated a bug in RnExpr.segments (#11612)
114 test11 :: M ()
115 test11 = do
116 x1 <- a
117 let x2 = x1
118 x3 <- b
119 let x4 = c
120 x5 = x4
121 return (const () (x1,x2,x3,x4))
122
123 -- (a | (b ; c))
124 -- The strict pattern match forces (b;c), but a can still be parallel (#13875)
125 test12 :: M ()
126 test12 = do
127 x1 <- a
128 () <- b
129 x2 <- c
130 return (const () (x1,x2))
131
132 main = mapM_ run
133 [ test1
134 , test2
135 , test3
136 , test4
137 , test5
138 , test6
139 , test7
140 , test8
141 , test9
142 , test10
143 , test11
144 , test12
145 ]
146
147 -- Testing code, prints out the structure of a monad/applicative expression
148
149 newtype M a = M (Bool -> (Maybe Doc, a))
150
151 maybeParen True d = parens d
152 maybeParen _ d = d
153
154 run :: M a -> IO ()
155 run (M m) = print d where (Just d,_) = m False
156
157 instance Functor M where
158 fmap f m = m >>= return . f
159
160 instance Applicative M where
161 pure a = M $ \_ -> (Nothing, a)
162 M f <*> M a = M $ \p ->
163 let (Just d1, f') = f True
164 (Just d2, a') = a True
165 in
166 (Just (maybeParen p (d1 <+> char '|' <+> d2)), f' a')
167
168 instance Monad M where
169 return = pure
170 M m >>= k = M $ \p ->
171 let (d1, a) = m True
172 (d2, b) = case k a of M f -> f True
173 in
174 case (d1,d2) of
175 (Nothing,Nothing) -> (Nothing, b)
176 (Just d, Nothing) -> (Just d, b)
177 (Nothing, Just d) -> (Just d, b)
178 (Just d1, Just d2) -> (Just (maybeParen p (d1 PP.<> semi <+> d2)), b)
179
180 doc :: String -> M ()
181 doc d = M $ \_ -> (Just (text d), ())