git.iko.soy/effects-benchmarks
on edf18f2 help sign in
c7e3543
swap
0 ahead, 4 behind
README.md+51−334
since splitsnapshots
unifiedsplit
@@ -1,388 +1,105 @@
1# effects-benchmarks
1# effects-benchmarks
2
2
3+This is a set of memory and time benchmarks for the various Haskell effects libraries, including `fused-effects`, `polysemy`, `freer-simple`, and `extensible-effects`. Benchmarks for equivalent `mtl` and handwritten computations are included for comparison purposes. It uses Cabal's new Backpack feature to save a great deal of boilerplate code.
3
4
4−## Results
5+# tl;dr
5
6
6−<details>
7+`fused-effects` and `mtl` achieve roughly commensurate performance. `polysemy` is within one to three orders of magnitude from `fused-effects` and `mtl`. `freer-simple` and `extensible-effects` are considerably slower.
7
8
8−<summary>Linux – Intel(R) Core(TM) i5-10210U CPU @ 1.60GHz</summary>
9+# Full results
9
10
10−```
11+On a 15-inch 2017 MacBook Pro (3.1GHz Intel i7, 16GB RAM), here are results for space benchmarks:
11−*** Time benchmarks ***
12−benchmarked Countdown/Put/fused-effects
13−time 13.54 ms (13.44 ms .. 13.67 ms)
14− 0.999 R² (0.998 R² .. 1.000 R²)
15−mean 13.58 ms (13.54 ms .. 13.69 ms)
16−std dev 165.6 μs (94.38 μs .. 276.3 μs)
17−
18−benchmarked Countdown/Put/mtl
19−time 4.885 ms (4.777 ms .. 4.954 ms)
20− 0.998 R² (0.993 R² .. 1.000 R²)
21−mean 4.995 ms (4.934 ms .. 5.227 ms)
22−std dev 333.6 μs (54.64 μs .. 696.6 μs)
23−variance introduced by outliers: 37% (moderately inflated)
24−
25−benchmarked Countdown/Put/polysemy
26−time 20.82 ms (20.58 ms .. 21.10 ms)
27− 0.999 R² (0.997 R² .. 1.000 R²)
28−mean 20.82 ms (20.70 ms .. 21.00 ms)
29−std dev 359.1 μs (243.7 μs .. 578.8 μs)
30−
31−benchmarked Countdown/Put/freer-simple
32−time 20.18 ms (19.82 ms .. 20.56 ms)
33− 0.998 R² (0.997 R² .. 0.999 R²)
34−mean 19.90 ms (19.56 ms .. 20.53 ms)
35−std dev 1.084 ms (524.8 μs .. 2.078 ms)
36−variance introduced by outliers: 22% (moderately inflated)
37−
38−benchmarked Countdown/Put/extensible-effects
39−time 22.01 ms (21.29 ms .. 22.72 ms)
40− 0.997 R² (0.995 R² .. 0.999 R²)
41−mean 20.74 ms (19.73 ms .. 21.26 ms)
42−std dev 1.554 ms (611.3 μs .. 2.309 ms)
43−variance introduced by outliers: 30% (moderately inflated)
44−
45−benchmarked Countdown/Put/shallow
46−time 2.432 ms (2.390 ms .. 2.477 ms)
47− 0.998 R² (0.997 R² .. 0.999 R²)
48−mean 2.439 ms (2.425 ms .. 2.456 ms)
49−std dev 47.42 μs (39.74 μs .. 62.97 μs)
50−
51−benchmarked Countdown/Put/effectful - static
52−time 555.5 μs (542.5 μs .. 567.2 μs)
53− 0.995 R² (0.985 R² .. 1.000 R²)
54−mean 548.2 μs (544.0 μs .. 561.4 μs)
55−std dev 19.40 μs (5.420 μs .. 41.81 μs)
56−variance introduced by outliers: 12% (moderately inflated)
57−
58−benchmarked Countdown/Put/effectful - dynamic
59−time 2.729 ms (2.688 ms .. 2.777 ms)
60− 0.998 R² (0.996 R² .. 0.999 R²)
61−mean 2.736 ms (2.722 ms .. 2.761 ms)
62−std dev 59.64 μs (42.50 μs .. 90.32 μs)
63−
64−benchmarked Countdown/Put+Exc/fused-effects
65−time 11.89 ms (11.76 ms .. 12.06 ms)
66− 0.999 R² (0.999 R² .. 1.000 R²)
67−mean 11.93 ms (11.87 ms .. 12.05 ms)
68−std dev 199.3 μs (102.4 μs .. 324.7 μs)
69−
70−benchmarked Countdown/Put+Exc/mtl
71−time 5.196 ms (5.120 ms .. 5.299 ms)
72− 0.998 R² (0.994 R² .. 0.999 R²)
73−mean 5.200 ms (5.169 ms .. 5.254 ms)
74−std dev 108.8 μs (69.46 μs .. 167.0 μs)
75−
76−benchmarked Countdown/Put+Exc/polysemy
77−time 29.24 ms (28.82 ms .. 29.79 ms)
78− 0.999 R² (0.998 R² .. 1.000 R²)
79−mean 29.51 ms (29.26 ms .. 29.95 ms)
80−std dev 681.2 μs (452.7 μs .. 990.8 μs)
81−
82−benchmarked Countdown/Put+Exc/freer-simple
83−time 13.32 ms (12.65 ms .. 14.12 ms)
84− 0.984 R² (0.974 R² .. 0.993 R²)
85−mean 11.50 ms (11.00 ms .. 11.99 ms)
86−std dev 1.209 ms (1.080 ms .. 1.435 ms)
87−variance introduced by outliers: 48% (moderately inflated)
88−
89−benchmarked Countdown/Put+Exc/extensible-effects
90−time 17.03 ms (15.01 ms .. 18.76 ms)
91− 0.956 R² (0.928 R² .. 0.980 R²)
92−mean 13.62 ms (12.99 ms .. 14.50 ms)
93−std dev 1.750 ms (1.315 ms .. 2.083 ms)
94−variance introduced by outliers: 56% (severely inflated)
95−
96−benchmarked Countdown/Put+Exc/shallow
97−time 580.0 μs (475.1 μs .. 675.5 μs)
98− 0.971 R² (0.958 R² .. 1.000 R²)
99−mean 573.0 μs (566.0 μs .. 584.6 μs)
100−std dev 14.90 μs (1.088 μs .. 19.80 μs)
101−
102−benchmarked Countdown/Put+Exc/effectful - static
103−time 588.1 μs (520.7 μs .. 679.1 μs)
104− 0.974 R² (0.954 R² .. 0.998 R²)
105−mean 602.3 μs (596.0 μs .. 612.8 μs)
106−std dev 13.75 μs (5.999 μs .. 17.97 μs)
107−
108−benchmarked Countdown/Put+Exc/effectful - dynamic
109−time 2.769 ms (2.747 ms .. 2.806 ms)
110− 0.997 R² (0.992 R² .. 1.000 R²)
111−mean 2.796 ms (2.783 ms .. 2.832 ms)
112−std dev 48.48 μs (21.03 μs .. 95.12 μs)
113−
114−benchmarked HTTP/fused-effects
115−time 1.937 ms (1.916 ms .. 1.976 ms)
116− 0.997 R² (0.993 R² .. 1.000 R²)
117−mean 1.937 ms (1.928 ms .. 1.957 ms)
118−std dev 29.94 μs (11.47 μs .. 54.28 μs)
119−
120−benchmarked HTTP/polysemy
121−time 34.56 ms (33.19 ms .. 36.29 ms)
122− 0.995 R² (0.992 R² .. 1.000 R²)
123−mean 33.67 ms (33.40 ms .. 34.39 ms)
124−std dev 841.1 μs (347.0 μs .. 1.492 ms)
125−
126−benchmarked HTTP/extensible-effects
127−time 19.92 ms (18.98 ms .. 21.52 ms)
128− 0.983 R² (0.970 R² .. 0.991 R²)
129−mean 17.74 ms (16.85 ms .. 18.62 ms)
130−std dev 1.942 ms (1.676 ms .. 2.228 ms)
131−variance introduced by outliers: 48% (moderately inflated)
132−
133−benchmarked HTTP/Deep embedding
134−time 28.14 ms (25.55 ms .. 30.55 ms)
135− 0.980 R² (0.966 R² .. 0.993 R²)
136−mean 24.73 ms (22.59 ms .. 26.22 ms)
137−std dev 3.694 ms (2.445 ms .. 4.726 ms)
138−variance introduced by outliers: 61% (severely inflated)
139−
140−benchmarking HTTP/Shallow embedding ... took 11.97 s, total 40147 iterations
141−benchmarked HTTP/Shallow embedding
142−time 22.38 μs (21.23 μs .. 23.27 μs)
143− 0.994 R² (0.977 R² .. 0.999 R²)
144−mean 25.00 μs (24.76 μs .. 25.35 μs)
145−std dev 484.0 ns (352.7 ns .. 601.7 ns)
146−
147−benchmarked HTTP/freer-simple
148−time 19.35 ms (18.52 ms .. 20.60 ms)
149− 0.980 R² (0.959 R² .. 0.992 R²)
150−mean 17.17 ms (16.27 ms .. 18.04 ms)
151−std dev 1.945 ms (1.653 ms .. 2.326 ms)
152−variance introduced by outliers: 45% (moderately inflated)
153−
154−benchmarking HTTP/effectful - static ... took 11.95 s, total 38223 iterations
155−benchmarked HTTP/effectful - static
156−time 25.03 μs (16.61 μs .. 35.70 μs)
157− 0.838 R² (0.740 R² .. 0.999 R²)
158−mean 25.57 μs (24.80 μs .. 27.01 μs)
159−std dev 1.644 μs (121.0 ns .. 2.127 μs)
160−variance introduced by outliers: 18% (moderately inflated)
161−
162−benchmarked HTTP/effectful - dynamic
163−time 4.058 ms (3.662 ms .. 4.753 ms)
164− 0.918 R² (0.847 R² .. 0.997 R²)
165−mean 3.886 ms (3.773 ms .. 4.122 ms)
166−std dev 397.4 μs (161.9 μs .. 614.5 μs)
167−variance introduced by outliers: 50% (severely inflated)
168−
169−*** Space benchmarks (these will take some time to run) ***
170
12
13+```
171Countdown
14Countdown
172
15
173− Case Allocated GCs
16+ Case Allocated
174− fused-effects 2,512 0
17+ fused-effects 40
175− mtl 792 0
18+ mtl 40
176− polysemy 4,184 0
19+ polysemy 1,304
177− freer-simple 1,120 0
20+ freer-simple 1,096
178− extensible-effects 1,264 0
21+ extensible-effects 1,304
179− shallow 232 0
22+ shallow 232
180− effectful - static 4,000,488 3
181− effectful - dynamic 14,401,376 13
182
23
183Countdown + exc
24Countdown + exc
184
25
185− Case Allocated GCs
26+ Case Allocated GCs
186− fused-effects 1,080 0
27+ fused-effects 336
187− mtl 608 0
28+ mtl 336
188− polysemy 4,144 0
29+ polysemy 792
189− freer-simple 576 0
30+ freer-simple 864
190− extensible-effects 688 0
31+ extensible-effects 984
191− shallow 0 0
32+ shallow 320
192− effectful - static 4,002,080 3
193− effectful - dynamic 14,403,832 13
194```
33```
195
34
196−</details>
35+(The fact that `fused-effects` and `mtl` have the same allocations is not an error; `fused-effects` was designed to have almost identical performance characteristics to `mtl`.)
197−
198−<details>
199
36
200−<summary>macOS – MacBook Pro (13-inch, 2018, Four Thunderbolt 3 Ports) – 2.3 GHz Quad-Core Intel Core i5</summary>
37+Time (`State`-based countdown):
201
38
202```
39```
203−*** Time benchmarks ***
204benchmarked Countdown/Put/fused-effects
40benchmarked Countdown/Put/fused-effects
205−time 13.54 ms (13.44 ms .. 13.67 ms)
41+time 5.692 μs (5.570 μs .. 5.835 μs)
206− 0.999 R² (0.998 R² .. 1.000 R²)
207−mean 13.58 ms (13.54 ms .. 13.69 ms)
208−std dev 165.6 μs (94.38 μs .. 276.3 μs)
209
42
210benchmarked Countdown/Put/mtl
43benchmarked Countdown/Put/mtl
211−time 4.885 ms (4.777 ms .. 4.954 ms)
44+time 5.500 μs (5.386 μs .. 5.719 μs)
212− 0.998 R² (0.993 R² .. 1.000 R²)
213−mean 4.995 ms (4.934 ms .. 5.227 ms)
214−std dev 333.6 μs (54.64 μs .. 696.6 μs)
215−variance introduced by outliers: 37% (moderately inflated)
216
45
217benchmarked Countdown/Put/polysemy
46benchmarked Countdown/Put/polysemy
218−time 20.82 ms (20.58 ms .. 21.10 ms)
47+time 1.903 ms (1.845 ms .. 1.954 ms)
219− 0.999 R² (0.997 R² .. 1.000 R²)
220−mean 20.82 ms (20.70 ms .. 21.00 ms)
221−std dev 359.1 μs (243.7 μs .. 578.8 μs)
222
48
223benchmarked Countdown/Put/freer-simple
49benchmarked Countdown/Put/freer-simple
224−time 20.18 ms (19.82 ms .. 20.56 ms)
50+time 1.324 ms (1.282 ms .. 1.361 ms)
225− 0.998 R² (0.997 R² .. 0.999 R²)
226−mean 19.90 ms (19.56 ms .. 20.53 ms)
227−std dev 1.084 ms (524.8 μs .. 2.078 ms)
228−variance introduced by outliers: 22% (moderately inflated)
229
51
230benchmarked Countdown/Put/extensible-effects
52benchmarked Countdown/Put/extensible-effects
231−time 22.01 ms (21.29 ms .. 22.72 ms)
53+time 1.383 ms (1.343 ms .. 1.422 ms)
232− 0.997 R² (0.995 R² .. 0.999 R²)
233−mean 20.74 ms (19.73 ms .. 21.26 ms)
234−std dev 1.554 ms (611.3 μs .. 2.309 ms)
235−variance introduced by outliers: 30% (moderately inflated)
236
54
237benchmarked Countdown/Put/shallow
55benchmarked Countdown/Put/shallow
238−time 2.432 ms (2.390 ms .. 2.477 ms)
56+time 275.1 μs (270.1 μs .. 281.6 μs)
239− 0.998 R² (0.997 R² .. 0.999 R²)
57+```
240−mean 2.439 ms (2.425 ms .. 2.456 ms)
58+
241−std dev 47.42 μs (39.74 μs .. 62.97 μs)
59+Time (`State` + `Error` countdown):
242−
243−benchmarked Countdown/Put/effectful - static
244−time 555.5 μs (542.5 μs .. 567.2 μs)
245− 0.995 R² (0.985 R² .. 1.000 R²)
246−mean 548.2 μs (544.0 μs .. 561.4 μs)
247−std dev 19.40 μs (5.420 μs .. 41.81 μs)
248−variance introduced by outliers: 12% (moderately inflated)
249−
250−benchmarked Countdown/Put/effectful - dynamic
251−time 2.729 ms (2.688 ms .. 2.777 ms)
252− 0.998 R² (0.996 R² .. 0.999 R²)
253−mean 2.736 ms (2.722 ms .. 2.761 ms)
254−std dev 59.64 μs (42.50 μs .. 90.32 μs)
255
60
61+```
256benchmarked Countdown/Put+Exc/fused-effects
62benchmarked Countdown/Put+Exc/fused-effects
257−time 11.89 ms (11.76 ms .. 12.06 ms)
63+time 9.829 μs (9.645 μs .. 10.04 μs)
258− 0.999 R² (0.999 R² .. 1.000 R²)
259−mean 11.93 ms (11.87 ms .. 12.05 ms)
260−std dev 199.3 μs (102.4 μs .. 324.7 μs)
261
64
262benchmarked Countdown/Put+Exc/mtl
65benchmarked Countdown/Put+Exc/mtl
263−time 5.196 ms (5.120 ms .. 5.299 ms)
66+time 9.968 μs (9.779 μs .. 10.15 μs)
264− 0.998 R² (0.994 R² .. 0.999 R²)
265−mean 5.200 ms (5.169 ms .. 5.254 ms)
266−std dev 108.8 μs (69.46 μs .. 167.0 μs)
267
67
268benchmarked Countdown/Put+Exc/polysemy
68benchmarked Countdown/Put+Exc/polysemy
269−time 29.24 ms (28.82 ms .. 29.79 ms)
69+time 418.1 μs (408.9 μs .. 427.1 μs)
270− 0.999 R² (0.998 R² .. 1.000 R²)
271−mean 29.51 ms (29.26 ms .. 29.95 ms)
272−std dev 681.2 μs (452.7 μs .. 990.8 μs)
273
70
274benchmarked Countdown/Put+Exc/freer-simple
71benchmarked Countdown/Put+Exc/freer-simple
275−time 13.32 ms (12.65 ms .. 14.12 ms)
72+time 1.157 ms (1.120 ms .. 1.199 ms)
276− 0.984 R² (0.974 R² .. 0.993 R²)
277−mean 11.50 ms (11.00 ms .. 11.99 ms)
278−std dev 1.209 ms (1.080 ms .. 1.435 ms)
279−variance introduced by outliers: 48% (moderately inflated)
280
73
281benchmarked Countdown/Put+Exc/extensible-effects
74benchmarked Countdown/Put+Exc/extensible-effects
282−time 17.03 ms (15.01 ms .. 18.76 ms)
75+time 1.232 ms (1.212 ms .. 1.262 ms)
283− 0.956 R² (0.928 R² .. 0.980 R²)
284−mean 13.62 ms (12.99 ms .. 14.50 ms)
285−std dev 1.750 ms (1.315 ms .. 2.083 ms)
286−variance introduced by outliers: 56% (severely inflated)
287
76
288benchmarked Countdown/Put+Exc/shallow
77benchmarked Countdown/Put+Exc/shallow
289−time 580.0 μs (475.1 μs .. 675.5 μs)
78+time 55.12 μs (54.34 μs .. 56.29 μs)
290− 0.971 R² (0.958 R² .. 1.000 R²)
79+```
291−mean 573.0 μs (566.0 μs .. 584.6 μs)
80+
292−std dev 14.90 μs (1.088 μs .. 19.80 μs)
81+Time (custom HTTP DSL):
293−
294−benchmarked Countdown/Put+Exc/effectful - static
295−time 588.1 μs (520.7 μs .. 679.1 μs)
296− 0.974 R² (0.954 R² .. 0.998 R²)
297−mean 602.3 μs (596.0 μs .. 612.8 μs)
298−std dev 13.75 μs (5.999 μs .. 17.97 μs)
299−
300−benchmarked Countdown/Put+Exc/effectful - dynamic
301−time 2.769 ms (2.747 ms .. 2.806 ms)
302− 0.997 R² (0.992 R² .. 1.000 R²)
303−mean 2.796 ms (2.783 ms .. 2.832 ms)
304−std dev 48.48 μs (21.03 μs .. 95.12 μs)
305
82
83+```
306benchmarked HTTP/fused-effects
84benchmarked HTTP/fused-effects
307−time 1.937 ms (1.916 ms .. 1.976 ms)
85+time 8.311 μs (8.060 μs .. 8.592 μs)
308− 0.997 R² (0.993 R² .. 1.000 R²)
309−mean 1.937 ms (1.928 ms .. 1.957 ms)
310−std dev 29.94 μs (11.47 μs .. 54.28 μs)
311
86
312benchmarked HTTP/polysemy
87benchmarked HTTP/polysemy
313−time 34.56 ms (33.19 ms .. 36.29 ms)
88+time 14.99 ms (14.26 ms .. 15.80 ms)
314− 0.995 R² (0.992 R² .. 1.000 R²)
315−mean 33.67 ms (33.40 ms .. 34.39 ms)
316−std dev 841.1 μs (347.0 μs .. 1.492 ms)
317
89
318benchmarked HTTP/extensible-effects
90benchmarked HTTP/extensible-effects
319−time 19.92 ms (18.98 ms .. 21.52 ms)
91+time 1.612 ms (1.578 ms .. 1.654 ms)
320− 0.983 R² (0.970 R² .. 0.991 R²)
321−mean 17.74 ms (16.85 ms .. 18.62 ms)
322−std dev 1.942 ms (1.676 ms .. 2.228 ms)
323−variance introduced by outliers: 48% (moderately inflated)
324
92
325benchmarked HTTP/Deep embedding
93benchmarked HTTP/Deep embedding
326−time 28.14 ms (25.55 ms .. 30.55 ms)
94+time 2.027 ms (1.876 ms .. 2.184 ms)
327− 0.980 R² (0.966 R² .. 0.993 R²)
328−mean 24.73 ms (22.59 ms .. 26.22 ms)
329−std dev 3.694 ms (2.445 ms .. 4.726 ms)
330−variance introduced by outliers: 61% (severely inflated)
331
95
332−benchmarking HTTP/Shallow embedding ... took 11.97 s, total 40147 iterations
333benchmarked HTTP/Shallow embedding
96benchmarked HTTP/Shallow embedding
334−time 22.38 μs (21.23 μs .. 23.27 μs)
97+time 15.94 μs (15.49 μs .. 16.46 μs)
335− 0.994 R² (0.977 R² .. 0.999 R²)
336−mean 25.00 μs (24.76 μs .. 25.35 μs)
337−std dev 484.0 ns (352.7 ns .. 601.7 ns)
338
98
339benchmarked HTTP/freer-simple
99benchmarked HTTP/freer-simple
340−time 19.35 ms (18.52 ms .. 20.60 ms)
100+time 1.478 ms (1.443 ms .. 1.515 ms)
341− 0.980 R² (0.959 R² .. 0.992 R²)
342−mean 17.17 ms (16.27 ms .. 18.04 ms)
343−std dev 1.945 ms (1.653 ms .. 2.326 ms)
344−variance introduced by outliers: 45% (moderately inflated)
345−
346−benchmarking HTTP/effectful - static ... took 11.95 s, total 38223 iterations
347−benchmarked HTTP/effectful - static
348−time 25.03 μs (16.61 μs .. 35.70 μs)
349− 0.838 R² (0.740 R² .. 0.999 R²)
350−mean 25.57 μs (24.80 μs .. 27.01 μs)
351−std dev 1.644 μs (121.0 ns .. 2.127 μs)
352−variance introduced by outliers: 18% (moderately inflated)
353−
354−benchmarked HTTP/effectful - dynamic
355−time 4.058 ms (3.662 ms .. 4.753 ms)
356− 0.918 R² (0.847 R² .. 0.997 R²)
357−mean 3.886 ms (3.773 ms .. 4.122 ms)
358−std dev 397.4 μs (161.9 μs .. 614.5 μs)
359−variance introduced by outliers: 50% (severely inflated)
360−
361−*** Space benchmarks (these will take some time to run) ***
362−
363−Countdown
364−
365− Case Allocated GCs
366− fused-effects 2,512 0
367− mtl 792 0
368− polysemy 4,184 0
369− freer-simple 1,120 0
370− extensible-effects 1,264 0
371− shallow 232 0
372− effectful - static 4,000,488 3
373− effectful - dynamic 14,401,376 13
374−
375−Countdown + exc
376−
377− Case Allocated GCs
378− fused-effects 1,080 0
379− mtl 608 0
380− polysemy 4,144 0
381− freer-simple 576 0
382− extensible-effects 688 0
383− shallow 0 0
384− effectful - static 4,002,080 3
385− effectful - dynamic 14,403,832 13
386```
101```
387
102
388−</details>
103+# Future work
104+* More benchmarks: `Writer`, logging, `grammar`, `pipes`.
105+* I am going to make this emit pretty graphs, or at least graphable .csv files, someday.
effects-benchmarks.cabal+1−29
@@ -1,6 +1,6 @@
1cabal-version: 1.12
1cabal-version: 1.12
2
2
3−-- This file has been generated from package.yaml by hpack version 0.34.4.
3+-- This file has been generated from package.yaml by hpack version 0.34.2.
4--
4--
5-- see: https://github.com/sol/hpack
5-- see: https://github.com/sol/hpack
6
6
@@ -14,14 +14,6 @@ benchmark effects-benchmarks
14 type: exitcode-stdio-1.0
14 type: exitcode-stdio-1.0
15 main-is: Main.hs
15 main-is: Main.hs
16 other-modules:
16 other-modules:
17− Effectful.Dynamic.Bench
18− Effectful.Dynamic.HTTP
19− Effectful.Dynamic.Stateful
20− Effectful.Dynamic.StatefulExcept
21− Effectful.Static.Bench
22− Effectful.Static.HTTP
23− Effectful.Static.Stateful
24− Effectful.Static.StatefulExcept
25 ExtEff.Bench
17 ExtEff.Bench
26 ExtEff.HTTP
18 ExtEff.HTTP
27 ExtEff.Stateful
19 ExtEff.Stateful
@@ -50,28 +42,8 @@ benchmark effects-benchmarks
50 hs-source-dirs:
42 hs-source-dirs:
51 instances
43 instances
52 src
44 src
53− default-extensions:
54− DeriveAnyClass
55− DeriveFunctor
56− DeriveGeneric
57− DerivingStrategies
58− FlexibleInstances
59− GADTs
60− GeneralizedNewtypeDeriving
61− KindSignatures
62− MultiParamTypeClasses
63− TypeOperators
64− UndecidableInstances
65− DataKinds
66− FlexibleContexts
67− TypeApplications
68− LambdaCase
69− ScopedTypeVariables
70− DerivingStrategies
71 build-depends:
45 build-depends:
72 base
46 base
73− , effectful
74− , effectful-core
75 , extensible-effects
47 , extensible-effects
76 , freer-simple
48 , freer-simple
77 , fused-effects
49 , fused-effects
hie.yamlnew file+7
@@ -0,0 +1,7 @@
1+cradle:
2+ stack:
3+ - path: "./instances"
4+ component: "effects-benchmarks:bench:effects-benchmarks"
5+
6+ - path: "./src/Main.hs"
7+ component: "effects-benchmarks:bench:effects-benchmarks"
instances/Effectful/Dynamic/Bench.hsdeleted−18
@@ -1,18 +0,0 @@
1−module Effectful.Dynamic.Bench where
2−
3−import Effectful
4−import Effectful.Dynamic.HTTP
5−import Effectful.Dynamic.Stateful
6−import Effectful.Dynamic.StatefulExcept
7−import Effectful.Error.Dynamic
8−import Effectful.State.Dynamic
9−import GHC.Stack (CallStack)
10−
11−countDownBench :: Int -> (Int, Int)
12−countDownBench start = runPureEff . runLocalState start $ countDownPut
13−
14−countDownExcBench :: Int -> Either (CallStack, String) (Int, Int)
15−countDownExcBench start = runPureEff . runError . runLocalState start $ countDownExc
16−
17−httpBench :: Int -> IO Int
18−httpBench n = runEff $ runHTTP (doHTTP n)
instances/Effectful/Dynamic/HTTP.hsdeleted−39
@@ -1,39 +0,0 @@
1−module Effectful.Dynamic.HTTP where
2−
3−import Control.Monad
4−import Data.Kind
5−import Effectful
6−import Effectful.Dispatch.Static
7−import Effectful.Internal.Monad
8−
9−data HTTP :: Effect where
10− Open :: String -> HTTP m ()
11− Close :: HTTP m ()
12− Post :: String -> HTTP m String
13− Get :: HTTP m String
14−
15−runHTTP :: Eff (HTTP : es) a -> Eff es a
16−runHTTP = interpret $ \_ -> \case
17− Open _ -> pure ()
18− Close -> pure ()
19− Post a -> pure ("posted" <> a)
20− Get -> pure "gotten"
21−
22−open :: HTTP :> es => String -> Eff es ()
23−open = send . Open
24−
25−close :: HTTP :> es => Eff es ()
26−close = send Close
27−
28−post :: HTTP :> es => String -> Eff es String
29−post = send . Post
30−
31−get :: HTTP :> es => Eff es String
32−get = send Get
33−
34−doHTTP :: HTTP :> es => Int -> Eff es Int
35−doHTTP n = do
36− open "cats"
37− replicateM_ n (get *> post "cats")
38− close
39− pure n
instances/Effectful/Dynamic/Stateful.hsdeleted−7
@@ -1,7 +0,0 @@
1−module Effectful.Dynamic.Stateful where
2−
3−import Effectful
4−import Effectful.State.Dynamic
5−
6−countDownPut :: State Int :> es => Eff es Int
7−countDownPut = get >>= (\n -> if n < 0 then pure n else put (n - 1) *> countDownPut)
instances/Effectful/Dynamic/StatefulExcept.hsdeleted−10
@@ -1,10 +0,0 @@
1−module Effectful.Dynamic.StatefulExcept where
2−
3−import Effectful
4−import Effectful.Error.Dynamic
5−import Effectful.State.Dynamic
6−
7−countDownExc :: (State Int :> es, Error String :> es) => Eff es b
8−countDownExc = go
9− where
10− go = get @Int >>= (\n -> if n <= 0 then throwError "what" else put @Int (n - 1) *> go)
instances/Effectful/Static/Bench.hsdeleted−17
@@ -1,17 +0,0 @@
1−module Effectful.Static.Bench where
2−
3−import Effectful
4−import Effectful.Error
5−import Effectful.State.Local
6−import Effectful.Static.HTTP
7−import Effectful.Static.Stateful
8−import Effectful.Static.StatefulExcept
9−
10−countDownBench :: Int -> (Int, Int)
11−countDownBench start = runPureEff . runState start $ countDownPut
12−
13−countDownExcBench :: Int -> Either (CallStack, String) (Int, Int)
14−countDownExcBench start = runPureEff . runError . runState start $ countDownExc
15−
16−httpBench :: Int -> IO Int
17−httpBench n = runEff $ runHTTP (doHTTP n)
instances/Effectful/Static/HTTP.hsdeleted−30
@@ -1,30 +0,0 @@
1−module Effectful.Static.HTTP where
2−
3−import Control.Monad
4−import Data.Kind
5−import Effectful
6−import Effectful.Dispatch.Static
7−
8−data HTTP (m :: Type -> Type) r = HTTP
9−
10−runHTTP :: Eff (HTTP : es) a -> Eff es a
11−runHTTP = evalData (DataA HTTP)
12−
13−open :: HTTP :> es => String -> Eff es ()
14−open _ = pure ()
15−
16−close :: HTTP :> es => Eff es ()
17−close = pure ()
18−
19−post :: HTTP :> es => String -> Eff es String
20−post a = pure ("posted" <> a)
21−
22−get :: HTTP :> es => Eff es String
23−get = pure "gotten"
24−
25−doHTTP :: HTTP :> es => Int -> Eff es Int
26−doHTTP n = do
27− open "cats"
28− replicateM_ n (get *> post "cats")
29− close
30− pure n
instances/Effectful/Static/Stateful.hsdeleted−7
@@ -1,7 +0,0 @@
1−module Effectful.Static.Stateful where
2−
3−import Effectful
4−import Effectful.State.Local
5−
6−countDownPut :: State Int :> es => Eff es Int
7−countDownPut = get >>= (\n -> if n < 0 then pure n else put (n - 1) *> countDownPut)
instances/Effectful/Static/StatefulExcept.hsdeleted−10
@@ -1,10 +0,0 @@
1−module Effectful.Static.StatefulExcept where
2−
3−import Effectful
4−import Effectful.Error
5−import Effectful.State.Local
6−
7−countDownExc :: (State Int :> es, Error String :> es) => Eff es b
8−countDownExc = go
9− where
10− go = get @Int >>= (\n -> if n <= 0 then throwError "what" else put @Int (n - 1) *> go)
instances/ExtEff/Bench.hs+8−9
@@ -1,16 +1,15 @@
1module ExtEff.Bench
1module ExtEff.Bench
2− ( countDownBench,
2+ ( countDownBench
3− countDownExcBench,
3+ , countDownExcBench
4− httpBench,
4+ , httpBench
5− )
6−where
5+ ) where
7
6
8−import Control.Eff
9−import Control.Eff.Exception
10−import Control.Eff.State.Strict
11−import ExtEff.HTTP
12import ExtEff.Stateful
7import ExtEff.Stateful
13import ExtEff.StatefulExcept
8import ExtEff.StatefulExcept
9+import ExtEff.HTTP
10+import Control.Eff.State.Strict
11+import Control.Eff.Exception
12+import Control.Eff
14
13
15countDownBench :: Int -> (Int, Int)
14countDownBench :: Int -> (Int, Int)
16countDownBench start = run . runState start $ countDownPut
15countDownBench start = run . runState start $ countDownPut
instances/ExtEff/HTTP.hs+17−13
@@ -1,42 +1,46 @@
1+{-# LANGUAGE DataKinds, TypeOperators, GADTs, FlexibleInstances, MultiParamTypeClasses #-}
2+
1module ExtEff.HTTP where
3module ExtEff.HTTP where
2
4
3import Control.Eff
5import Control.Eff
4import Control.Eff.Extend
6import Control.Eff.Extend
5−import Control.Monad
6import Data.Function
7import Data.Function
8+import Control.Monad
9+
10+type HttpM = Eff '[HTTP, Lift IO]
7
11
8data HTTP a where
12data HTTP a where
9 Open :: String -> HTTP ()
13 Open :: String -> HTTP ()
10 Close :: HTTP ()
14 Close :: HTTP ()
11− Post :: String -> HTTP String
15+ Post :: String -> HTTP String
12− HGet :: HTTP String
16+ HGet :: HTTP String
13
17
14−open' :: Member HTTP e => String -> Eff e ()
18+open' :: String -> HttpM ()
15−open' = send . Open
19+open' = send . Open
16
20
17−close' :: Member HTTP e => Eff e ()
21+close' :: HttpM ()
18close' = send Close
22close' = send Close
19
23
20−post' :: Member HTTP e => String -> Eff e String
24+post' :: String -> HttpM String
21post' = send . Post
25post' = send . Post
22
26
23−get' :: Member HTTP e => Eff e String
27+get' :: HttpM String
24get' = send HGet
28get' = send HGet
25
29
26instance Handle HTTP r b (Eff e b) where
30instance Handle HTTP r b (Eff e b) where
27 handle h q req = case req of
31 handle h q req = case req of
28 Open _s -> h (q ^$ ())
32 Open _s -> h (q ^$ ())
29− Close -> h (q ^$ ())
33+ Close -> h (q ^$ ())
30− Post s -> h (q ^$ ("posted " <> s))
34+ Post s -> h (q ^$ ("posted " <> s))
31− HGet -> h (q ^$ "contents")
35+ HGet -> h (q ^$ "contents")
32
36
33doHttp :: Eff (HTTP ': e) b -> Eff e b
37doHttp :: Eff (HTTP ': e) b -> Eff e b
34doHttp = fix (handle_relay pure)
38doHttp = fix (handle_relay pure)
35
39
36−runHttp :: Eff '[HTTP, Lift IO] a -> IO a
40+runHttp :: HttpM a -> IO a
37runHttp = runLift . doHttp
41runHttp = runLift . doHttp
38
42
39−doHTTP :: Member HTTP e => Int -> Eff e Int
43+doHTTP :: Int -> Eff '[HTTP, Lift IO] Int
40doHTTP n = do
44doHTTP n = do
41 open' "cats"
45 open' "cats"
42 replicateM_ n (get' *> post' "cats")
46 replicateM_ n (get' *> post' "cats")
instances/ExtEff/Stateful.hs+4
@@ -1,3 +1,7 @@
1+{-# LANGUAGE MonoLocalBinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE DataKinds, TypeApplications #-}
4+
1module ExtEff.Stateful where
5module ExtEff.Stateful where
2
6
3import Control.Eff
7import Control.Eff
instances/ExtEff/StatefulExcept.hs+4−1
@@ -1,8 +1,11 @@
1+{-# LANGUAGE MonoLocalBinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE TypeApplications, DataKinds #-}
1module ExtEff.StatefulExcept where
4module ExtEff.StatefulExcept where
2
5
3import Control.Eff
6import Control.Eff
4−import Control.Eff.Exception
5import Control.Eff.State.Strict
7import Control.Eff.State.Strict
8+import Control.Eff.Exception
6
9
7countDownExc :: (Member (State Int) r, Member (Exc String) r) => Eff r b
10countDownExc :: (Member (State Int) r, Member (Exc String) r) => Eff r b
8countDownExc = get @Int >>= (\n -> if n <= 0 then throwError "what" else put @Int (n - 1) *> countDownExc)
11countDownExc = get @Int >>= (\n -> if n <= 0 then throwError "what" else put @Int (n - 1) *> countDownExc)
instances/Freer/Bench.hs+8−9
@@ -1,16 +1,15 @@
1module Freer.Bench
1module Freer.Bench
2− ( countDownBench,
2+ ( countDownBench
3− countDownExcBench,
3+ , countDownExcBench
4− httpBench,
4+ , httpBench
5− )
6−where
5+ ) where
7
6
8−import Control.Monad.Freer
9−import Control.Monad.Freer.Error
10−import Control.Monad.Freer.State
11−import Freer.HTTP
12import Freer.Stateful
7import Freer.Stateful
13import Freer.StatefulExcept
8import Freer.StatefulExcept
9+import Freer.HTTP
10+import Control.Monad.Freer.State
11+import Control.Monad.Freer.Error
12+import Control.Monad.Freer
14
13
15countDownBench :: Int -> (Int, Int)
14countDownBench :: Int -> (Int, Int)
16countDownBench start = run . runState start $ countDownPut
15countDownBench start = run . runState start $ countDownPut
instances/Freer/HTTP.hs+21−19
@@ -1,40 +1,42 @@
1+{-# LANGUAGE DataKinds, TypeOperators, GADTs #-}
2+
1module Freer.HTTP where
3module Freer.HTTP where
2
4
3−import Control.Monad
4import Control.Monad.Freer
5import Control.Monad.Freer
6+import Control.Monad
7+
8+type HttpM = Eff '[HTTP, IO]
5
9
6data HTTP a where
10data HTTP a where
7 Open :: String -> HTTP ()
11 Open :: String -> HTTP ()
8 Close :: HTTP ()
12 Close :: HTTP ()
9− Post :: String -> HTTP String
13+ Post :: String -> HTTP String
10− HGet :: HTTP String
14+ HGet :: HTTP String
11
15
12−open' :: Member HTTP e => String -> Eff e ()
16+open' :: String -> HttpM ()
13−open' = send . Open
17+open' = send . Open
14
18
15−close' :: Member HTTP e => Eff e ()
19+close' :: HttpM ()
16close' = send Close
20close' = send Close
17
21
18−post' :: Member HTTP e => String -> Eff e String
22+post' :: String -> HttpM String
19post' = send . Post
23post' = send . Post
20
24
21−get' :: Member HTTP e => Eff e String
25+get' :: HttpM String
22get' = send HGet
26get' = send HGet
23
27
24doHttp :: Eff (HTTP ': e) b -> Eff e b
28doHttp :: Eff (HTTP ': e) b -> Eff e b
25−doHttp =
26− interpret
29+doHttp = interpret
27− ( \x -> case x of
30+ (\x -> case x of
28− Open _ -> pure ()
31+ Open _ -> pure ()
29− Close -> pure ()
32+ Close -> pure ()
30− Post a -> pure ("posted" <> a)
33+ Post a -> pure ("posted" <> a)
31− HGet -> pure "gotten"
34+ HGet -> pure "gotten")
32− )
35+
33−
34−runHttp :: Eff '[HTTP, IO] a -> IO a
36+runHttp :: HttpM a -> IO a
35runHttp = runM . doHttp
37runHttp = runM . doHttp
36
38
37−doHTTP :: Member HTTP e => Int -> Eff e Int
39+doHTTP :: Int -> Eff '[HTTP, IO] Int
38doHTTP n = do
40doHTTP n = do
39 open' "cats"
41 open' "cats"
40 replicateM_ n (get' *> post' "cats")
42 replicateM_ n (get' *> post' "cats")
instances/Freer/Stateful.hs+4
@@ -1,3 +1,7 @@
1+{-# LANGUAGE MonoLocalBinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE TypeApplications, DataKinds #-}
4+
1module Freer.Stateful where
5module Freer.Stateful where
2
6
3import Control.Monad.Freer
7import Control.Monad.Freer
instances/Freer/StatefulExcept.hs+5−5
@@ -1,10 +1,10 @@
1+{-# LANGUAGE TypeApplications, DataKinds #-}
1module Freer.StatefulExcept where
2module Freer.StatefulExcept where
2
3
3import Control.Monad.Freer
4import Control.Monad.Freer
4−import Control.Monad.Freer.Error
5import Control.Monad.Freer.State
5import Control.Monad.Freer.State
6+import Control.Monad.Freer.Error
6
7
7−countDownExc :: (Member (State Int) e, Member (Error String) e) => Eff e b
8+countDownExc :: Eff '[State Int, Error String] b
8−countDownExc = go
9+countDownExc = go where
9− where
10− go = get @Int >>= (\n -> if n <= 0 then throwError "what" else put @Int (n - 1) *> go)
10+ go = get @Int >>= (\n -> if n <= 0 then throwError "what" else put @Int (n - 1) *> go)
instances/Fused/Bench.hs+7−8
@@ -1,15 +1,14 @@
1module Fused.Bench
1module Fused.Bench
2− ( countDownBench,
2+ ( countDownBench
3− countDownExcBench,
3+ , countDownExcBench
4− httpBench,
4+ , httpBench
5− )
6−where
5+ ) where
7
6
8−import Control.Carrier.Error.Either
9−import Control.Carrier.State.Strict
10−import Fused.HTTP
11import Fused.Stateful
7import Fused.Stateful
12import Fused.StatefulExcept
8import Fused.StatefulExcept
9+import Fused.HTTP
10+import Control.Carrier.State.Strict
11+import Control.Carrier.Error.Either
13
12
14countDownBench :: Int -> (Int, Int)
13countDownBench :: Int -> (Int, Int)
15countDownBench start = run . runState start $ countDownPut
14countDownBench start = run . runState start $ countDownPut
instances/Fused/HTTP.hs+32−26
@@ -1,45 +1,51 @@
1+{-# LANGUAGE DeriveAnyClass, DeriveFunctor, DeriveGeneric, DerivingStrategies, FlexibleInstances, GeneralizedNewtypeDeriving,
2+ KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
3+
1module Fused.HTTP where
4module Fused.HTTP where
2
5
3import Control.Algebra
6import Control.Algebra
4−import Control.Carrier.Lift
5−import Control.Monad
6import Control.Monad.IO.Class
7import Control.Monad.IO.Class
7−import Data.Functor
8import GHC.Generics (Generic1)
8import GHC.Generics (Generic1)
9+import Control.Carrier.Lift
10+import Control.Monad
9
11
10−newtype HttpC m a = HttpC {runHttpC :: m a}
12+newtype HttpC m a = HttpC { runHttpC :: m a }
11 deriving newtype (Applicative, Functor, Monad, MonadIO)
13 deriving newtype (Applicative, Functor, Monad, MonadIO)
12
14
13−data HTTP (m :: * -> *) k where
15+data HTTP (m :: * -> *) k
14− Open :: String -> HTTP m ()
16+ = Open String (m k)
15− Close :: HTTP m ()
17+ | Close (m k)
16− Post :: String -> HTTP m String
18+ | Post String (String -> m k)
19+ | HGet (String -> m k)
20+ deriving stock (Functor, Generic1)
21+ deriving anyclass (HFunctor, Effect)
22+
17− HGet :: HTTP m String
23+open' :: String -> HttpM ()
24+open' s = send (Open s (pure ()))
18
25
19−open' :: Has HTTP sig m => String -> m ()
26+close' :: HttpM ()
20−open' s = send (Open s)
27+close' = send (Close (pure ()))
21
28
22−close' :: Has HTTP sig m => m ()
29+post' :: String -> HttpM String
23−close' = send Close
30+post' s = send (Post s pure)
24
31
25−post' :: Has HTTP sig m => String -> m String
32+get' :: HttpM String
26−post' s = send (Post s)
33+get' = send (HGet pure)
27
34
28−get' :: Has HTTP sig m => m String
35+type HttpM = HttpC (LiftC IO)
29−get' = send HGet
30
36
31−instance (Algebra sig m) => Algebra (HTTP :+: sig) (HttpC m) where
37+instance (Effect sig, Algebra sig m) => Algebra (HTTP :+: sig) (HttpC m) where
32− alg hdl (L act) ctx = case act of
38+ alg (L act) = case act of
33− Open _ -> pure ctx
39+ Open _ k -> k
34− Close -> pure ctx
40+ Close k -> k
35− Post s -> pure $ ctx $> ("posted " <> s)
41+ Post s k -> k ("posted " <> s)
36− HGet -> pure $ ctx $> "lmao"
42+ HGet k -> k "lmao"
37− alg hdl (R other) ctx = HttpC (alg (runHttpC . hdl) other ctx)
43+ alg (R other) = HttpC (alg (handleCoercible other))
38
44
39−runHttp :: HttpC (LiftC IO) a -> IO a
45+runHttp :: HttpM a -> IO a
40runHttp = runM . runHttpC
46runHttp = runM . runHttpC
41
47
42−doHTTP :: Has HTTP sig m => Int -> m Int
48+doHTTP :: Int -> HttpC (LiftC IO) Int
43doHTTP n = do
49doHTTP n = do
44 open' "cats"
50 open' "cats"
45 replicateM_ n (get' *> post' "cats")
51 replicateM_ n (get' *> post' "cats")
instances/Fused/Stateful.hs+2
@@ -1,3 +1,5 @@
1+{-# LANGUAGE TypeApplications #-}
2+
1module Fused.Stateful where
3module Fused.Stateful where
2
4
3import Control.Effect.State
5import Control.Effect.State
instances/Fused/StatefulExcept.hs+4
@@ -1,8 +1,12 @@
1+{-# LANGUAGE TypeApplications #-}
2+
1module Fused.StatefulExcept where
3module Fused.StatefulExcept where
2
4
5+
3import Control.Effect.Error
6import Control.Effect.Error
4import Control.Effect.State
7import Control.Effect.State
5
8
9+
6countDownExc :: (Has (State Int) sig m, Has (Error String) sig m) => m a
10countDownExc :: (Has (State Int) sig m, Has (Error String) sig m) => m a
7countDownExc =
11countDownExc =
8 get @Int >>= (\n -> if n <= 0 then throwError "what" else put @Int (n - 1) *> countDownExc)
12 get @Int >>= (\n -> if n <= 0 then throwError "what" else put @Int (n - 1) *> countDownExc)
instances/MTL/Bench.hs+7−8
@@ -1,15 +1,14 @@
1module MTL.Bench
1module MTL.Bench
2− ( countDownBench,
2+ ( countDownBench
3− countDownExcBench,
3+ , countDownExcBench
4− httpBench,
4+ , httpBench
5− )
6−where
5+ ) where
7
6
8−import Control.Monad.Except
9−import Control.Monad.State.Strict
10−import MTL.HTTP
11import MTL.Stateful
7import MTL.Stateful
12import MTL.StatefulExcept
8import MTL.StatefulExcept
9+import MTL.HTTP
10+import Control.Monad.State.Strict
11+import Control.Monad.Except
13
12
14countDownBench :: Int -> (Int, Int)
13countDownBench :: Int -> (Int, Int)
15countDownBench start = flip runState start $ countDownPut
14countDownBench start = flip runState start $ countDownPut
instances/MTL/HTTP.hs+9−7
@@ -1,3 +1,5 @@
1+{-# LANGUAGE GADTs, LambdaCase #-}
2+
1module MTL.HTTP where
3module MTL.HTTP where
2
4
3import Control.Applicative
5import Control.Applicative
@@ -16,7 +18,7 @@ instance Functor HttpM where
16 fmap = liftA
18 fmap = liftA
17
19
18instance Applicative HttpM where
20instance Applicative HttpM where
19− pure = Pure
21+ pure = Pure
20 (<*>) = ap
22 (<*>) = ap
21
23
22instance Monad HttpM where
24instance Monad HttpM where
@@ -36,13 +38,13 @@ open' = Open
36
38
37runHttp :: HttpM a -> IO a
39runHttp :: HttpM a -> IO a
38runHttp = \case
40runHttp = \case
39− Pure x -> pure x
41+ Pure x -> pure x
40− Lift m -> m
42+ Lift m -> m
41 Then x f -> runHttp x >>= runHttp . f
43 Then x f -> runHttp x >>= runHttp . f
42− Open _ -> pure ()
44+ Open _ -> pure ()
43− Shut -> pure ()
45+ Shut -> pure ()
44− Post s -> pure ("posted " <> s)
46+ Post s -> pure ("posted " <> s)
45− HGet -> pure "lmap"
47+ HGet -> pure "lmap"
46
48
47doHTTP :: Int -> HttpM Int
49doHTTP :: Int -> HttpM Int
48doHTTP n = do
50doHTTP n = do
instances/MTL/Stateful.hs+1
@@ -1,3 +1,4 @@
1+{-# LANGUAGE FlexibleContexts #-}
1module MTL.Stateful where
2module MTL.Stateful where
2
3
3import Control.Monad.State.Class
4import Control.Monad.State.Class
instances/MTL/StatefulExcept.hs+2−1
@@ -1,7 +1,8 @@
1+{-# LANGUAGE FlexibleContexts #-}
1module MTL.StatefulExcept where
2module MTL.StatefulExcept where
2
3
3−import Control.Monad.Error.Class
4import Control.Monad.State.Class
4import Control.Monad.State.Class
5+import Control.Monad.Error.Class
5
6
6countDownExc :: (MonadState Int m, MonadError String m) => m a
7countDownExc :: (MonadState Int m, MonadError String m) => m a
7countDownExc = get >>= (\n -> if n <= 0 then throwError "what" else put (n - 1) *> countDownExc)
8countDownExc = get >>= (\n -> if n <= 0 then throwError "what" else put (n - 1) *> countDownExc)
instances/Poly/Bench.hs+6−7
@@ -1,16 +1,15 @@
1module Poly.Bench
1module Poly.Bench
2− ( countDownBench,
2+ ( countDownBench
3− countDownExcBench,
3+ , countDownExcBench
4− httpBench,
4+ , httpBench
5− )
6−where
5+ ) where
7
6
8−import Poly.HTTP
9import Poly.Stateful
7import Poly.Stateful
10import Poly.StatefulExcept
8import Poly.StatefulExcept
9+import Poly.HTTP
10+import Polysemy.State
11import Polysemy
11import Polysemy
12import Polysemy.Error
12import Polysemy.Error
13−import Polysemy.State
14
13
15countDownBench :: Int -> (Int, Int)
14countDownBench :: Int -> (Int, Int)
16countDownBench start = run . runState start $ countDownPut
15countDownBench start = run . runState start $ countDownPut
instances/Poly/HTTP.hs+13−13
@@ -1,43 +1,43 @@
1−{-# LANGUAGE TemplateHaskell #-}
1+{-# LANGUAGE ScopedTypeVariables, DataKinds, TemplateHaskell, KindSignatures, GADTs, FlexibleContexts, TypeOperators, LambdaCase #-}
2
2
3module Poly.HTTP where
3module Poly.HTTP where
4
4
5−import Control.Monad
6import Polysemy
5import Polysemy
6+import Control.Monad
7
7
8type HttpM = Sem '[Http, Final IO]
8type HttpM = Sem '[Http, Final IO]
9
9
10data Http (m :: * -> *) a where
10data Http (m :: * -> *) a where
11− HOpen :: String -> Http m ()
11+ HOpen :: String -> Http m ()
12 HClose :: Http m ()
12 HClose :: Http m ()
13− HPost :: String -> Http m String
13+ HPost :: String -> Http m String
14− HGet :: Http m String
14+ HGet :: Http m String
15
15
16makeSem ''Http
16makeSem ''Http
17
17
18−open' :: Member Http r => String -> Sem r ()
18+open' :: String -> HttpM ()
19−open' = hOpen
19+open' = hOpen
20
20
21−close' :: Member Http r => Sem r ()
21+close' :: HttpM ()
22close' = hClose
22close' = hClose
23
23
24−post' :: Member Http r => String -> Sem r String
24+post' :: String -> HttpM String
25post' = hPost
25post' = hPost
26
26
27−get' :: Member Http r => Sem r String
27+get' :: HttpM String
28get' = hGet
28get' = hGet
29
29
30runHttp' :: Sem (Http ': r) a -> Sem r a
30runHttp' :: Sem (Http ': r) a -> Sem r a
31runHttp' = interpret $ \case
31runHttp' = interpret $ \case
32 HOpen _ -> pure ()
32 HOpen _ -> pure ()
33− HClose -> pure ()
33+ HClose -> pure ()
34 HPost s -> pure ("posted " <> s)
34 HPost s -> pure ("posted " <> s)
35− HGet -> pure "contents"
35+ HGet -> pure "contents"
36
36
37runHttp :: HttpM a -> IO a
37runHttp :: HttpM a -> IO a
38runHttp = runFinal . runHttp'
38runHttp = runFinal . runHttp'
39
39
40−doHTTP :: Member Http r => Int -> Sem r Int
40+doHTTP :: Int -> Sem '[Http, Final IO] Int
41doHTTP n = do
41doHTTP n = do
42 open' "cats"
42 open' "cats"
43 replicateM_ n (get' *> post' "cats")
43 replicateM_ n (get' *> post' "cats")
instances/Poly/Stateful.hs+4
@@ -1,3 +1,7 @@
1+{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE DataKinds, TypeApplications #-}
4+
1module Poly.Stateful where
5module Poly.Stateful where
2
6
3import Polysemy
7import Polysemy
instances/Poly/StatefulExcept.hs+4−1
@@ -1,8 +1,11 @@
1+{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE TypeApplications, DataKinds #-}
1module Poly.StatefulExcept where
4module Poly.StatefulExcept where
2
5
3import Polysemy
6import Polysemy
4−import Polysemy.Error
5import Polysemy.State
7import Polysemy.State
8+import Polysemy.Error
6
9
7countDownExc :: (Member (State Int) r, Member (Error String) r) => Sem r a
10countDownExc :: (Member (State Int) r, Member (Error String) r) => Sem r a
8countDownExc = get @Int >>= (\n -> if n <= 0 then throw "what" else put @Int (n - 1) *> countDownExc)
11countDownExc = get @Int >>= (\n -> if n <= 0 then throw "what" else put @Int (n - 1) *> countDownExc)
instances/Shallow/Bench.hs+5−6
@@ -1,13 +1,12 @@
1module Shallow.Bench
1module Shallow.Bench
2− ( countDownBench,
2+ ( countDownBench
3− countDownExcBench,
3+ , countDownExcBench
4− httpBench,
4+ , httpBench
5− )
6−where
5+ ) where
7
6
8−import Shallow.HTTP
9import Shallow.Stateful
7import Shallow.Stateful
10import Shallow.StatefulExcept
8import Shallow.StatefulExcept
9+import Shallow.HTTP
11
10
12countDownBench :: Int -> (Int, Int)
11countDownBench :: Int -> (Int, Int)
13countDownBench = countDownPut
12countDownBench = countDownPut
instances/Shallow/HTTP.hs+4−2
@@ -1,9 +1,11 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+
1module Shallow.HTTP where
3module Shallow.HTTP where
2
4
3import Control.Monad
5import Control.Monad
4
6
5−newtype HttpM a = HttpM {runHttp :: IO a}
7+newtype HttpM a = HttpM { runHttp :: IO a}
6− deriving newtype (Applicative, Functor, Monad)
8+ deriving (Applicative, Functor, Monad)
7
9
8get' :: HttpM String
10get' :: HttpM String
9get' = pure "lmao"
11get' = pure "lmao"
instances/Shallow/Stateful.hs+3−4
@@ -2,7 +2,7 @@ module Shallow.Stateful where
2
2
3import Control.Monad
3import Control.Monad
4
4
5−newtype StateM a = StateM {unStateM :: Int -> (Int, a)}
5+newtype StateM a = StateM { unStateM :: Int -> (Int, a) }
6
6
7instance Functor StateM where
7instance Functor StateM where
8 fmap f (StateM a) = StateM (\n -> fmap f (a n))
8 fmap f (StateM a) = StateM (\n -> fmap f (a n))
@@ -24,6 +24,5 @@ runStateful :: Int -> StateM a -> (Int, a)
24runStateful n (StateM f) = f $! n
24runStateful n (StateM f) = f $! n
25
25
26countDownPut :: Int -> (Int, Int)
26countDownPut :: Int -> (Int, Int)
27−countDownPut start = runStateful start go
27+countDownPut start = runStateful start go where
28− where
29− go = get >>= (\n -> if n < 0 then pure n else put (n - 1) *> go)
28+ go = get >>= (\n -> if n < 0 then pure n else put (n - 1) *> go)
instances/Shallow/StatefulExcept.hs+8−10
@@ -1,8 +1,10 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+
1module Shallow.StatefulExcept where
3module Shallow.StatefulExcept where
2
4
3import Control.Monad
5import Control.Monad
4
6
5−newtype StateM a = StateM {unStateM :: Int -> Either String (Int, a)}
7+newtype StateM a = StateM { unStateM :: Int -> Either String (Int, a) }
6
8
7instance Functor StateM where
9instance Functor StateM where
8 fmap f (StateM a) = StateM (\n -> fmap (fmap f) (a n))
10 fmap f (StateM a) = StateM (\n -> fmap (fmap f) (a n))
@@ -12,12 +14,9 @@ instance Applicative StateM where
12 (<*>) = ap
14 (<*>) = ap
13
15
14instance Monad StateM where
16instance Monad StateM where
15− (StateM a) >>= f =
16− StateM
17− ( \n -> case a n of
17+ (StateM a) >>= f = StateM (\n -> case a n of
18− Left s -> Left s
18+ Left s -> Left s
19− Right (n', x) -> unStateM (f x) n'
19+ Right (n', x) -> unStateM (f x) n')
20− )
21
20
22get :: StateM Int
21get :: StateM Int
23get = StateM (\n -> Right (n, n))
22get = StateM (\n -> Right (n, n))
@@ -32,6 +31,5 @@ runStatefulExcept :: Int -> StateM a -> Either String (Int, a)
32runStatefulExcept n (StateM f) = f $! n
31runStatefulExcept n (StateM f) = f $! n
33
32
34countDownExc :: Int -> Either String (Int, Int)
33countDownExc :: Int -> Either String (Int, Int)
35−countDownExc start = runStatefulExcept start go
34+countDownExc start = runStatefulExcept start go where
36− where
37− go = get >>= (\n -> if n <= 0 then throw "what" else put (n - 1) *> go)
35+ go = get >>= (\n -> if n <= 0 then throw "what" else put (n - 1) *> go)
package.yaml−20
@@ -12,26 +12,6 @@ benchmarks:
12 - extensible-effects
12 - extensible-effects
13 - gauge
13 - gauge
14 - weigh
14 - weigh
15− - effectful
16− - effectful-core
17 source-dirs:
15 source-dirs:
18 - instances
16 - instances
19 - src
17 - src
20− default-extensions:
21− - DeriveAnyClass
22− - DeriveFunctor
23− - DeriveGeneric
24− - DerivingStrategies
25− - FlexibleInstances
26− - GADTs
27− - GeneralizedNewtypeDeriving
28− - KindSignatures
29− - MultiParamTypeClasses
30− - TypeOperators
31− - UndecidableInstances
32− - DataKinds
33− - FlexibleContexts
34− - TypeApplications
35− - LambdaCase
36− - ScopedTypeVariables
37− - DerivingStrategies
src/Main.hs+50−68
@@ -1,90 +1,72 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE FlexibleContexts #-}
1+{-# LANGUAGE FlexibleContexts, GADTs, CPP #-}
3−{-# LANGUAGE GADTs #-}
4
2
5module Main where
3module Main where
6
4
7−import qualified Effectful.Dynamic.Bench as EffectfulDynamic
8−import qualified Effectful.Static.Bench as EffectfulStatic
9−import qualified ExtEff.Bench as ExtEff
10−import qualified Freer.Bench as Freer
11−import qualified Fused.Bench as Fused
12import Gauge (bench, bgroup, nf, nfAppIO)
5import Gauge (bench, bgroup, nf, nfAppIO)
13import Gauge.Main (defaultMain)
6import Gauge.Main (defaultMain)
7+import qualified Weigh
8+
9+import qualified Fused.Bench as Fused
10+import qualified Freer.Bench as Freer
11+import qualified Shallow.Bench as Shallow
14import qualified MTL.Bench as MTL
12import qualified MTL.Bench as MTL
15import qualified Poly.Bench as Poly
13import qualified Poly.Bench as Poly
16−import qualified Shallow.Bench as Shallow
14+import qualified ExtEff.Bench as ExtEff
17−import qualified Weigh
18
15
19wruns :: Int
16wruns :: Int
20wruns = 1
17wruns = 1
21
18
22runs :: Int
19runs :: Int
23−runs = 100000
20+runs = 10000
24
21
25main :: IO ()
22main :: IO ()
26main = do
23main = do
27 putStrLn "*** Time benchmarks ***"
24 putStrLn "*** Time benchmarks ***"
28 defaultMain
25 defaultMain
29− [ bgroup
26+ [
30− "Countdown"
27+ bgroup "Countdown"
31− [ bgroup
28+ [ bgroup "Put"
32− "Put"
33− [ bench "fused-effects" (nf Fused.countDownBench runs),
29+ [ bench "fused-effects" (nf Fused.countDownBench runs)
34− bench "mtl" (nf MTL.countDownBench runs),
30+ , bench "mtl" (nf MTL.countDownBench runs)
35− bench "polysemy" (nf Poly.countDownBench runs),
31+ , bench "polysemy" (nf Poly.countDownBench runs)
36− bench "freer-simple" (nf Freer.countDownBench runs),
32+ , bench "freer-simple" (nf Freer.countDownBench runs)
37− bench "extensible-effects" (nf ExtEff.countDownBench runs),
38− bench "shallow" (nf Shallow.countDownBench runs),
39− bench "effectful - static" (nf EffectfulStatic.countDownBench runs),
40− bench "effectful - dynamic" (nf EffectfulDynamic.countDownBench runs)
41− ],
42− bgroup
43− "Put+Exc"
44− [ bench "fused-effects" (nf Fused.countDownExcBench runs),
45− bench "mtl" (nf MTL.countDownExcBench runs),
46− bench "polysemy" (nf Poly.countDownExcBench runs),
47− bench "freer-simple" (nf Freer.countDownExcBench runs),
48− bench "extensible-effects" (nf ExtEff.countDownExcBench runs),
33+ , bench "extensible-effects" (nf ExtEff.countDownBench runs)
49− bench "shallow" (nf Shallow.countDownExcBench runs),
34+ , bench "shallow" (nf Shallow.countDownBench runs)
50− bench "effectful - static" (nf EffectfulStatic.countDownExcBench runs),
51− bench "effectful - dynamic" (nf EffectfulDynamic.countDownExcBench runs)
52− ]
53− ],
54− bgroup
55− "HTTP"
56− [ bench "fused-effects" (nfAppIO Fused.httpBench runs),
57− bench "polysemy" (nfAppIO Poly.httpBench runs),
58− bench "extensible-effects" (nfAppIO ExtEff.httpBench runs),
59− bench "Deep embedding" (nfAppIO MTL.httpBench runs),
60− bench "Shallow embedding" (nfAppIO Shallow.httpBench runs),
61− bench "freer-simple" (nfAppIO Freer.httpBench runs),
62− bench "effectful - static" (nfAppIO EffectfulStatic.httpBench runs),
63− bench "effectful - dynamic" (nfAppIO EffectfulDynamic.httpBench runs)
64 ]
35 ]
36+ , bgroup "Put+Exc"
37+ [ bench "fused-effects" (nf Fused.countDownExcBench runs)
38+ , bench "mtl" (nf MTL.countDownExcBench runs)
39+ , bench "polysemy" (nf Poly.countDownExcBench runs)
40+ , bench "freer-simple" (nf Freer.countDownExcBench runs)
41+ , bench "extensible-effects" (nf ExtEff.countDownExcBench runs)
42+ , bench "shallow" (nf Shallow.countDownExcBench runs)
43+ ]
44+ ]
45+ , bgroup "HTTP"
46+ [ bench "fused-effects" (nfAppIO Fused.httpBench runs)
47+ , bench "polysemy" (nfAppIO Poly.httpBench runs)
48+ , bench "extensible-effects" (nfAppIO ExtEff.httpBench runs)
49+ , bench "Deep embedding" (nfAppIO MTL.httpBench runs)
50+ , bench "Shallow embedding" (nfAppIO Shallow.httpBench runs)
51+ , bench "freer-simple" (nfAppIO Freer.httpBench runs)
52+ ]
65 ]
53 ]
66
54
67 putStrLn "*** Space benchmarks (these will take some time to run) ***"
55 putStrLn "*** Space benchmarks (these will take some time to run) ***"
68 Weigh.mainWith $ do
56 Weigh.mainWith $ do
69− Weigh.wgroup "Countdown" $
57+ Weigh.wgroup "Countdown" $ sequence_
70− sequence_
71− [ Weigh.func "fused-effects" Fused.countDownBench wruns,
58+ [ Weigh.func "fused-effects" Fused.countDownBench wruns
72− Weigh.func "mtl" MTL.countDownBench wruns,
59+ , Weigh.func "mtl" MTL.countDownBench wruns
73− Weigh.func "polysemy" Poly.countDownBench wruns,
60+ , Weigh.func "polysemy" Poly.countDownBench wruns
74− Weigh.func "freer-simple" Freer.countDownBench wruns,
61+ , Weigh.func "freer-simple" Freer.countDownBench wruns
75− Weigh.func "extensible-effects" ExtEff.countDownBench wruns,
62+ , Weigh.func "extensible-effects" ExtEff.countDownBench wruns
76− Weigh.func "shallow" Shallow.countDownBench wruns,
63+ , Weigh.func "shallow" Shallow.countDownBench wruns
77− Weigh.func "effectful - static" EffectfulStatic.countDownBench runs,
78− Weigh.func "effectful - dynamic" EffectfulDynamic.countDownBench runs
79− ]
64+ ]
80− Weigh.wgroup "Countdown + exc" $
65+ Weigh.wgroup "Countdown + exc" $ sequence_
81− sequence_
82− [ Weigh.func "fused-effects" Fused.countDownExcBench wruns,
66+ [ Weigh.func "fused-effects" Fused.countDownExcBench wruns
83− Weigh.func "mtl" MTL.countDownExcBench wruns,
67+ , Weigh.func "mtl" MTL.countDownExcBench wruns
84− Weigh.func "polysemy" Poly.countDownExcBench wruns,
68+ , Weigh.func "polysemy" Poly.countDownExcBench wruns
85− Weigh.func "freer-simple" Freer.countDownExcBench wruns,
69+ , Weigh.func "freer-simple" Freer.countDownExcBench wruns
86− Weigh.func "extensible-effects" ExtEff.countDownExcBench wruns,
70+ , Weigh.func "extensible-effects" ExtEff.countDownExcBench wruns
87− Weigh.func "shallow" Shallow.countDownExcBench wruns,
71+ , Weigh.func "shallow" Shallow.countDownExcBench wruns
88− Weigh.func "effectful - static" EffectfulStatic.countDownExcBench runs,
89− Weigh.func "effectful - dynamic" EffectfulDynamic.countDownExcBench runs
90− ]
72+ ]
stack.yaml+3−15
@@ -17,7 +17,7 @@
17#
17#
18# resolver: ./custom-snapshot.yaml
18# resolver: ./custom-snapshot.yaml
19# resolver: https://example.com/snapshots/2018-01-01.yaml
19# resolver: https://example.com/snapshots/2018-01-01.yaml
20−resolver: lts-18.21
20+resolver: lts-16.18
21
21
22# User packages to be built.
22# User packages to be built.
23# Various formats can be used as shown in the example below.
23# Various formats can be used as shown in the example below.
@@ -29,7 +29,7 @@ resolver: lts-18.21
29# - auto-update
29# - auto-update
30# - wai
30# - wai
31packages:
31packages:
32− - .
32+- .
33# Dependency packages to be pulled from upstream that are not in the resolver.
33# Dependency packages to be pulled from upstream that are not in the resolver.
34# These entries can reference officially published versions as well as
34# These entries can reference officially published versions as well as
35# forks / in-progress versions pinned to a git hash. For example:
35# forks / in-progress versions pinned to a git hash. For example:
@@ -39,14 +39,7 @@ packages:
39# - git: https://github.com/commercialhaskell/stack.git
39# - git: https://github.com/commercialhaskell/stack.git
40# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
40# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
41#
41#
42−extra-deps:
42+# extra-deps: []
43− - fused-effects-1.1.1.1
44− - git: https://github.com/arybczak/effectful.git
45− commit: 0d0283948ddd3204f69cdc60871978efe21452ae
46− subdir: effectful
47− - git: https://github.com/arybczak/effectful.git
48− commit: 0d0283948ddd3204f69cdc60871978efe21452ae
49− subdir: effectful-core
50
43
51# Override default flag values for local packages and extra-deps
44# Override default flag values for local packages and extra-deps
52# flags: {}
45# flags: {}
@@ -71,8 +64,3 @@ extra-deps:
71#
64#
72# Allow a newer minor version of GHC than the snapshot specifies
65# Allow a newer minor version of GHC than the snapshot specifies
73# compiler-check: newer-minor
66# compiler-check: newer-minor
74−
75−ghc-options:
76− "$everything": -O2
77−
78−rebuild-ghc-options: true