git.iko.soy/effects-benchmarks
on master help sign in
swap
c7e354317 ahead, 0 behind
.gitignore+1
since splitsnapshots
unifiedsplit
@@ -1,4 +1,5 @@
1.stack-work
1.stack-work
2.DS_Store
2.DS_Store
3core-html/
3core-html/
4+dist
4dist-newstyle/
5dist-newstyle/
README.md+334−47
@@ -1,101 +1,388 @@
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.
4
3
5−# Some results
4+## Results
6
5
7−On a 15-inch 2017 MacBook Pro (3.1GHz Intel i7, 16GB RAM), here are results for space benchmarks:
6+<details>
7+
8+<summary>Linux – Intel(R) Core(TM) i5-10210U CPU @ 1.60GHz</summary>
8
9
9```
10```
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+
10Countdown
171Countdown
11
172
12− Case Allocated
173+ Case Allocated GCs
13− fused-effects 40
174+ fused-effects 2,512 0
14− mtl 40
175+ mtl 792 0
15− polysemy 1,304
176+ polysemy 4,184 0
16− freer-simple 1,096
177+ freer-simple 1,120 0
17− extensible-effects 1,304
178+ extensible-effects 1,264 0
18− shallow 232
179+ shallow 232 0
180+ effectful - static 4,000,488 3
181+ effectful - dynamic 14,401,376 13
19
182
20Countdown + exc
183Countdown + exc
21
184
22− Case Allocated GCs
185+ Case Allocated GCs
23− fused-effects 336
186+ fused-effects 1,080 0
24− mtl 336
187+ mtl 608 0
25− polysemy 792
188+ polysemy 4,144 0
26− freer-simple 864
189+ freer-simple 576 0
27− extensible-effects 984
190+ extensible-effects 688 0
28− shallow 320
191+ shallow 0 0
192+ effectful - static 4,002,080 3
193+ effectful - dynamic 14,403,832 13
29```
194```
30
195
31−Time (`State`-based countdown):
196+</details>
197+
198+<details>
199+
200+<summary>macOS – MacBook Pro (13-inch, 2018, Four Thunderbolt 3 Ports) – 2.3 GHz Quad-Core Intel Core i5</summary>
32
201
33```
202```
203+*** Time benchmarks ***
34benchmarked Countdown/Put/fused-effects
204benchmarked Countdown/Put/fused-effects
35−time 5.692 μs (5.570 μs .. 5.835 μs)
205+time 13.54 ms (13.44 ms .. 13.67 ms)
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)
36
209
37benchmarked Countdown/Put/mtl
210benchmarked Countdown/Put/mtl
38−time 5.500 μs (5.386 μs .. 5.719 μs)
211+time 4.885 ms (4.777 ms .. 4.954 ms)
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)
39−variance introduced by outliers: 35% (moderately inflated)
215+variance introduced by outliers: 37% (moderately inflated)
40
216
41benchmarked Countdown/Put/polysemy
217benchmarked Countdown/Put/polysemy
42−time 1.903 ms (1.845 ms .. 1.954 ms)
218+time 20.82 ms (20.58 ms .. 21.10 ms)
43−variance introduced by outliers: 72% (severely inflated)
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)
44
222
45benchmarked Countdown/Put/freer-simple
223benchmarked Countdown/Put/freer-simple
46−time 1.324 ms (1.282 ms .. 1.361 ms)
224+time 20.18 ms (19.82 ms .. 20.56 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)
47
229
48benchmarked Countdown/Put/extensible-effects
230benchmarked Countdown/Put/extensible-effects
49−time 1.383 ms (1.343 ms .. 1.422 ms)
231+time 22.01 ms (21.29 ms .. 22.72 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)
50
236
51benchmarked Countdown/Put/shallow
237benchmarked Countdown/Put/shallow
52−time 275.1 μs (270.1 μs .. 281.6 μs)
238+time 2.432 ms (2.390 ms .. 2.477 ms)
53−```
239+ 0.998 R² (0.997 R² .. 0.999 R²)
240+mean 2.439 ms (2.425 ms .. 2.456 ms)
241+std dev 47.42 μs (39.74 μs .. 62.97 μs)
54
242
55−Time (`State` + `Error` countdown):
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)
56
255
57−```
58benchmarked Countdown/Put+Exc/fused-effects
256benchmarked Countdown/Put+Exc/fused-effects
59−time 9.829 μs (9.645 μs .. 10.04 μs)
257+time 11.89 ms (11.76 ms .. 12.06 ms)
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)
60
261
61benchmarked Countdown/Put+Exc/mtl
262benchmarked Countdown/Put+Exc/mtl
62−time 9.968 μs (9.779 μs .. 10.15 μs)
263+time 5.196 ms (5.120 ms .. 5.299 ms)
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)
63
267
64benchmarked Countdown/Put+Exc/polysemy
268benchmarked Countdown/Put+Exc/polysemy
65−time 418.1 μs (408.9 μs .. 427.1 μs)
269+time 29.24 ms (28.82 ms .. 29.79 ms)
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)
66
273
67benchmarked Countdown/Put+Exc/freer-simple
274benchmarked Countdown/Put+Exc/freer-simple
68−time 1.157 ms (1.120 ms .. 1.199 ms)
275+time 13.32 ms (12.65 ms .. 14.12 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)
69
280
70benchmarked Countdown/Put+Exc/extensible-effects
281benchmarked Countdown/Put+Exc/extensible-effects
71−time 1.232 ms (1.212 ms .. 1.262 ms)
282+time 17.03 ms (15.01 ms .. 18.76 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)
72
287
73benchmarked Countdown/Put+Exc/shallow
288benchmarked Countdown/Put+Exc/shallow
74−time 55.12 μs (54.34 μs .. 56.29 μs)
289+time 580.0 μs (475.1 μs .. 675.5 μs)
75−```
290+ 0.971 R² (0.958 R² .. 1.000 R²)
291+mean 573.0 μs (566.0 μs .. 584.6 μs)
292+std dev 14.90 μs (1.088 μs .. 19.80 μs)
76
293
77−Time (custom HTTP DSL):
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)
78
305
79−```
80benchmarked HTTP/fused-effects
306benchmarked HTTP/fused-effects
81−time 8.311 μs (8.060 μs .. 8.592 μs)
307+time 1.937 ms (1.916 ms .. 1.976 ms)
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)
82
311
83benchmarked HTTP/polysemy
312benchmarked HTTP/polysemy
84−time 14.99 ms (14.26 ms .. 15.80 ms)
313+time 34.56 ms (33.19 ms .. 36.29 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)
85
317
86benchmarked HTTP/extensible-effects
318benchmarked HTTP/extensible-effects
87−time 1.612 ms (1.578 ms .. 1.654 ms)
319+time 19.92 ms (18.98 ms .. 21.52 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)
88
324
89benchmarked HTTP/Deep embedding
325benchmarked HTTP/Deep embedding
90−time 2.027 ms (1.876 ms .. 2.184 ms)
326+time 28.14 ms (25.55 ms .. 30.55 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)
91
331
332+benchmarking HTTP/Shallow embedding ... took 11.97 s, total 40147 iterations
92benchmarked HTTP/Shallow embedding
333benchmarked HTTP/Shallow embedding
93−time 15.94 μs (15.49 μs .. 16.46 μs)
334+time 22.38 μs (21.23 μs .. 23.27 μ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)
94
338
95benchmarked HTTP/freer-simple
339benchmarked HTTP/freer-simple
96−time 1.478 ms (1.443 ms .. 1.515 ms)
340+time 19.35 ms (18.52 ms .. 20.60 ms)
97−```
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)
98
360
99−# Future work
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+```
100
387
101−I am going to make this emit pretty graphs, or at least graphable .csv files, someday.
388+</details>
effects-benchmarks.cabal+78−93
@@ -1,97 +1,82 @@
1−cabal-version: 2.2
1+cabal-version: 1.12
2−name: effects-benchmarks
3−version: 0.1.0.0
4−homepage: https://github.com/patrickt/effects-benchmarks#readme
5−license: BSD-3-Clause
6−license-file: LICENSE
7−author: Author name here
8−maintainer: example@example.com
9−copyright: 2018 Author name here
10−category: Web
11−build-type: Simple
12−extra-source-files: README.md
13
2
14−common shared
3+-- This file has been generated from package.yaml by hpack version 0.34.4.
15− default-language: Haskell2010
4+--
16− ghc-options: -Wall -Werror -O2
5+-- see: https://github.com/sol/hpack
17− build-depends: base >= 4.7 && < 5
18
6
19−library benchmark-signatures
7+name: effects-benchmarks
20− import: shared
8+version: 0.0.0
21− hs-source-dirs: src
9+license: BSD3
22− signatures: Bench.Signature.Stateful
10+license-file: LICENSE
23− , Bench.Signature.StatefulExcept
11+build-type: Simple
24− , Bench.Signature.HTTP
25− exposed-modules: Bench.Countdown
26− , Bench.HTTP
27−
28−library instances-for-shallow
29− import: shared
30− hs-source-dirs: instances
31− default-extensions: StrictData
32− exposed-modules: Shallow.HTTP
33− , Shallow.Stateful
34− , Shallow.StatefulExcept
35−
36−library instances-for-exteff
37− import: shared
38− hs-source-dirs: instances
39− exposed-modules: ExtEff.Stateful
40− , ExtEff.StatefulExcept
41− , ExtEff.HTTP
42− build-depends: extensible-effects ^>= 5.0.0.1
43−
44−library instances-for-mtl
45− import: shared
46− hs-source-dirs: instances
47− exposed-modules: MTLStateful
48− , MTL.StatefulExcept
49− , MTL.HTTP
50− build-depends: mtl ^>= 2.2.2
51−
52−library instances-for-fused-effects
53− import: shared
54− hs-source-dirs: instances
55− exposed-modules: Fused.Stateful
56− , Fused.StatefulExcept
57− , Fused.HTTP
58− build-depends: fused-effects >= 0.3.1.0
59−
60−library instances-for-freer-simple
61− import: shared
62− hs-source-dirs: instances
63− exposed-modules: FSStateful
64− , Freer.StatefulExcept
65− , Freer.HTTP
66− build-depends: freer-simple ^>= 1.2.1
67−
68−library instances-for-polysemy
69− import: shared
70− hs-source-dirs: instances
71− exposed-modules: Poly.Stateful
72− , Poly.StatefulExcept
73− , Poly.HTTP
74− build-depends: polysemy ^>= 0.1.2
75
12
76benchmark effects-benchmarks
13benchmark effects-benchmarks
77− import: shared
78− type: exitcode-stdio-1.0
14+ type: exitcode-stdio-1.0
15+ main-is: Main.hs
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
26+ ExtEff.HTTP
27+ ExtEff.Stateful
28+ ExtEff.StatefulExcept
29+ Freer.Bench
30+ Freer.HTTP
31+ Freer.Stateful
32+ Freer.StatefulExcept
33+ Fused.Bench
34+ Fused.HTTP
35+ Fused.Stateful
36+ Fused.StatefulExcept
37+ MTL.Bench
38+ MTL.HTTP
39+ MTL.Stateful
40+ MTL.StatefulExcept
41+ Poly.Bench
42+ Poly.HTTP
43+ Poly.Stateful
44+ Poly.StatefulExcept
45+ Shallow.Bench
46+ Shallow.HTTP
47+ Shallow.Stateful
48+ Shallow.StatefulExcept
49+ Paths_effects_benchmarks
79− hs-source-dirs: src
50+ hs-source-dirs:
51+ instances
52+ 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
80− build-depends: benchmark-signatures
71+ build-depends:
81− , instances-for-mtl
72+ base
82− , instances-for-fused-effects
73+ , effectful
74+ , effectful-core
75+ , extensible-effects
83− , instances-for-freer-simple
76+ , freer-simple
84− , instances-for-polysemy
77+ , fused-effects
85− , instances-for-shallow
86− , instances-for-exteff
87− , dump-core
88− , gauge
78+ , gauge
79+ , mtl
80+ , polysemy
89− , weigh
81+ , weigh
90− , polysemy
82+ default-language: Haskell2010
91− main-is: Main.hs
92− mixins: benchmark-signatures (Bench.Countdown as MTL.Countdown, Bench.HTTP as MTL.HTTPM) requires (Bench.Signature.Stateful as MTLStateful, Bench.Signature.StatefulExcept as MTL.StatefulExcept, Bench.Signature.HTTP as MTL.HTTP)
93− , benchmark-signatures (Bench.Countdown as Fused.Countdown, Bench.HTTP as Fused.HTTPM) requires (Bench.Signature.Stateful as Fused.Stateful, Bench.Signature.StatefulExcept as Fused.StatefulExcept, Bench.Signature.HTTP as Fused.HTTP)
94− , benchmark-signatures (Bench.Countdown as Simple.Countdown, Bench.HTTP as Simple.HTTPM) requires (Bench.Signature.Stateful as FSStateful, Bench.Signature.StatefulExcept as Freer.StatefulExcept, Bench.Signature.HTTP as Freer.HTTP)
95− , benchmark-signatures (Bench.Countdown as Shallow.Countdown, Bench.HTTP as Shallow.HTTPM) requires (Bench.Signature.Stateful as Shallow.Stateful, Bench.Signature.StatefulExcept as Shallow.StatefulExcept, Bench.Signature.HTTP as Shallow.HTTP)
96− , benchmark-signatures (Bench.Countdown as Poly.Countdown, Bench.HTTP as Poly.HTTPM) requires (Bench.Signature.Stateful as Poly.Stateful, Bench.Signature.StatefulExcept as Poly.StatefulExcept, Bench.Signature.HTTP as Poly.HTTP)
97− , benchmark-signatures (Bench.Countdown as ExtEff.Countdown, Bench.HTTP as ExtEff.HTTPM) requires (Bench.Signature.Stateful as ExtEff.Stateful, Bench.Signature.StatefulExcept as ExtEff.StatefulExcept, Bench.Signature.HTTP as ExtEff.HTTP)
instances/Effectful/Dynamic/Bench.hsnew file+18
@@ -0,0 +1,18 @@
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.hsnew file+39
@@ -0,0 +1,39 @@
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.hsnew file+7
@@ -0,0 +1,7 @@
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.hsnew file+10
@@ -0,0 +1,10 @@
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.hsnew file+17
@@ -0,0 +1,17 @@
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.hsnew file+30
@@ -0,0 +1,30 @@
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.hsnew file+7
@@ -0,0 +1,7 @@
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.hsnew file+10
@@ -0,0 +1,10 @@
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.hsnew file+22
@@ -0,0 +1,22 @@
1+module ExtEff.Bench
2+ ( countDownBench,
3+ countDownExcBench,
4+ httpBench,
5+ )
6+where
7+
8+import Control.Eff
9+import Control.Eff.Exception
10+import Control.Eff.State.Strict
11+import ExtEff.HTTP
12+import ExtEff.Stateful
13+import ExtEff.StatefulExcept
14+
15+countDownBench :: Int -> (Int, Int)
16+countDownBench start = run . runState start $ countDownPut
17+
18+countDownExcBench :: Int -> Either String (Int, Int)
19+countDownExcBench start = run . runError . runState start $ countDownExc
20+
21+httpBench :: Int -> IO Int
22+httpBench n = runHttp (doHTTP n)
instances/ExtEff/HTTP.hs+19−15
@@ -1,40 +1,44 @@
1−{-# LANGUAGE DataKinds, TypeOperators, GADTs, FlexibleInstances, MultiParamTypeClasses #-}
2−
3module ExtEff.HTTP where
1module ExtEff.HTTP where
4
2
5import Control.Eff
3import Control.Eff
6import Control.Eff.Extend
4import Control.Eff.Extend
5+import Control.Monad
7import Data.Function
6import Data.Function
8
7
9−type HttpM = Eff '[HTTP, Lift IO]
10−
11data HTTP a where
8data HTTP a where
12 Open :: String -> HTTP ()
9 Open :: String -> HTTP ()
13 Close :: HTTP ()
10 Close :: HTTP ()
14− Post :: String -> HTTP String
11+ Post :: String -> HTTP String
15− HGet :: HTTP String
12+ HGet :: HTTP String
16
13
17−open' :: String -> HttpM ()
14+open' :: Member HTTP e => String -> Eff e ()
18−open' = send . Open
15+open' = send . Open
19
16
20−close' :: HttpM ()
17+close' :: Member HTTP e => Eff e ()
21close' = send Close
18close' = send Close
22
19
23−post' :: String -> HttpM String
20+post' :: Member HTTP e => String -> Eff e String
24post' = send . Post
21post' = send . Post
25
22
26−get' :: HttpM String
23+get' :: Member HTTP e => Eff e String
27get' = send HGet
24get' = send HGet
28
25
29instance Handle HTTP r b (Eff e b) where
26instance Handle HTTP r b (Eff e b) where
30 handle h q req = case req of
27 handle h q req = case req of
31 Open _s -> h (q ^$ ())
28 Open _s -> h (q ^$ ())
32− Close -> h (q ^$ ())
29+ Close -> h (q ^$ ())
33− Post s -> h (q ^$ ("posted " <> s))
30+ Post s -> h (q ^$ ("posted " <> s))
34− HGet -> h (q ^$ "contents")
31+ HGet -> h (q ^$ "contents")
35
32
36doHttp :: Eff (HTTP ': e) b -> Eff e b
33doHttp :: Eff (HTTP ': e) b -> Eff e b
37doHttp = fix (handle_relay pure)
34doHttp = fix (handle_relay pure)
38
35
39−runHttp :: HttpM a -> IO a
36+runHttp :: Eff '[HTTP, Lift IO] a -> IO a
40runHttp = runLift . doHttp
37runHttp = runLift . doHttp
38+
39+doHTTP :: Member HTTP e => Int -> Eff e Int
40+doHTTP n = do
41+ open' "cats"
42+ replicateM_ n (get' *> post' "cats")
43+ close'
44+ pure n
instances/ExtEff/Stateful.hs+3−14
@@ -1,18 +1,7 @@
1−{-# LANGUAGE DataKinds, TypeApplications #-}
2−
3module ExtEff.Stateful where
1module ExtEff.Stateful where
4
2
5import Control.Eff
3import Control.Eff
6−import Control.Eff.State.Strict as State
4+import Control.Eff.State.Strict
7−import Data.Tuple
8−
9−type StateM = Eff '[State Int]
10−
11−get :: StateM Int
12−get = State.get @Int
13−
14−put :: Int -> StateM ()
15−put = State.put @Int
16
5
17−runStateful :: Int -> StateM a -> (Int, a)
6+countDownPut :: Member (State Int) r => Eff r Int
18−runStateful n x = swap . run $ State.runState n x
7+countDownPut = get >>= (\n -> if n < 0 then pure n else put (n - 1) *> countDownPut)
instances/ExtEff/StatefulExcept.hs+3−16
@@ -1,21 +1,8 @@
1−{-# LANGUAGE TypeApplications, DataKinds #-}
2module ExtEff.StatefulExcept where
1module ExtEff.StatefulExcept where
3
2
4import Control.Eff
3import Control.Eff
5−import Control.Eff.State.Strict as State
6import Control.Eff.Exception
4import Control.Eff.Exception
7−import Data.Tuple
5+import Control.Eff.State.Strict
8
6
9−type StateM = Eff '[State Int, Exc String]
7+countDownExc :: (Member (State Int) r, Member (Exc String) r) => Eff r b
10−
8+countDownExc = get @Int >>= (\n -> if n <= 0 then throwError "what" else put @Int (n - 1) *> countDownExc)
11−get :: StateM Int
12−get = State.get @Int
13−
14−put :: Int -> StateM ()
15−put = State.put @Int
16−
17−throw :: String -> StateM a
18−throw = throwError
19−
20−runStatefulExcept :: Int -> StateM a -> Either String (Int, a)
21−runStatefulExcept n x = fmap swap . run . runError $ State.runState n x
instances/FSStateful.hsdeleted−18
@@ -1,18 +0,0 @@
1−{-# LANGUAGE TypeApplications, DataKinds #-}
2−
3−module FSStateful where
4−
5−import Control.Monad.Freer
6−import Control.Monad.Freer.State as State
7−import Data.Tuple
8−
9−type StateM = Eff '[State Int]
10−
11−get :: StateM Int
12−get = State.get @Int
13−
14−put :: Int -> StateM ()
15−put = State.put @Int
16−
17−runStateful :: Int -> StateM a -> (Int, a)
18−runStateful n x = swap . run $ State.runState n x
instances/Freer/Bench.hsnew file+22
@@ -0,0 +1,22 @@
1+module Freer.Bench
2+ ( countDownBench,
3+ countDownExcBench,
4+ httpBench,
5+ )
6+where
7+
8+import Control.Monad.Freer
9+import Control.Monad.Freer.Error
10+import Control.Monad.Freer.State
11+import Freer.HTTP
12+import Freer.Stateful
13+import Freer.StatefulExcept
14+
15+countDownBench :: Int -> (Int, Int)
16+countDownBench start = run . runState start $ countDownPut
17+
18+countDownExcBench :: Int -> Either String (Int, Int)
19+countDownExcBench start = run . runError . runState start $ countDownExc
20+
21+httpBench :: Int -> IO Int
22+httpBench n = runHttp (doHTTP n)
instances/Freer/HTTP.hs+25−19
@@ -1,36 +1,42 @@
1−{-# LANGUAGE DataKinds, TypeOperators, GADTs #-}
2−
3module Freer.HTTP where
1module Freer.HTTP where
4
2
3+import Control.Monad
5import Control.Monad.Freer
4import Control.Monad.Freer
6
5
7−type HttpM = Eff '[HTTP, IO]
8−
9data HTTP a where
6data HTTP a where
10 Open :: String -> HTTP ()
7 Open :: String -> HTTP ()
11 Close :: HTTP ()
8 Close :: HTTP ()
12− Post :: String -> HTTP String
9+ Post :: String -> HTTP String
13− HGet :: HTTP String
10+ HGet :: HTTP String
14
11
15−open' :: String -> HttpM ()
12+open' :: Member HTTP e => String -> Eff e ()
16−open' = send . Open
13+open' = send . Open
17
14
18−close' :: HttpM ()
15+close' :: Member HTTP e => Eff e ()
19close' = send Close
16close' = send Close
20
17
21−post' :: String -> HttpM String
18+post' :: Member HTTP e => String -> Eff e String
22post' = send . Post
19post' = send . Post
23
20
24−get' :: HttpM String
21+get' :: Member HTTP e => Eff e String
25get' = send HGet
22get' = send HGet
26
23
27doHttp :: Eff (HTTP ': e) b -> Eff e b
24doHttp :: Eff (HTTP ': e) b -> Eff e b
25+doHttp =
28−doHttp = interpret
26+ interpret
29− (\x -> case x of
27+ ( \x -> case x of
30− Open _ -> pure ()
28+ Open _ -> pure ()
31− Close -> pure ()
29+ Close -> pure ()
32− Post a -> pure ("posted" <> a)
30+ Post a -> pure ("posted" <> a)
33− HGet -> pure "gotten")
31+ HGet -> pure "gotten"
34−
32+ )
33+
35−runHttp :: HttpM a -> IO a
34+runHttp :: Eff '[HTTP, IO] a -> IO a
36runHttp = runM . doHttp
35runHttp = runM . doHttp
36+
37+doHTTP :: Member HTTP e => Int -> Eff e Int
38+doHTTP n = do
39+ open' "cats"
40+ replicateM_ n (get' *> post' "cats")
41+ close'
42+ pure n
instances/Freer/Stateful.hsnew file+7
@@ -0,0 +1,7 @@
1+module Freer.Stateful where
2+
3+import Control.Monad.Freer
4+import Control.Monad.Freer.State as State
5+
6+countDownPut :: Member (State Int) r => Eff r Int
7+countDownPut = get >>= (\n -> if n < 0 then pure n else put (n - 1) *> countDownPut)
instances/Freer/StatefulExcept.hs+5−16
@@ -1,21 +1,10 @@
1−{-# LANGUAGE TypeApplications, DataKinds #-}
2module Freer.StatefulExcept where
1module Freer.StatefulExcept where
3
2
4import Control.Monad.Freer
3import Control.Monad.Freer
5−import Control.Monad.Freer.State as State
6import Control.Monad.Freer.Error
4import Control.Monad.Freer.Error
7−import Data.Tuple
5+import Control.Monad.Freer.State
8
6
9−type StateM = Eff '[State Int, Error String]
7+countDownExc :: (Member (State Int) e, Member (Error String) e) => Eff e b
10−
8+countDownExc = go
11−get :: StateM Int
9+ where
12−get = State.get @Int
10+ go = get @Int >>= (\n -> if n <= 0 then throwError "what" else put @Int (n - 1) *> go)
13−
14−put :: Int -> StateM ()
15−put = State.put @Int
16−
17−throw :: String -> StateM a
18−throw = throwError
19−
20−runStatefulExcept :: Int -> StateM a -> Either String (Int, a)
21−runStatefulExcept n x = fmap swap . run . runError $ State.runState n x
instances/Fused/Bench.hsnew file+21
@@ -0,0 +1,21 @@
1+module Fused.Bench
2+ ( countDownBench,
3+ countDownExcBench,
4+ httpBench,
5+ )
6+where
7+
8+import Control.Carrier.Error.Either
9+import Control.Carrier.State.Strict
10+import Fused.HTTP
11+import Fused.Stateful
12+import Fused.StatefulExcept
13+
14+countDownBench :: Int -> (Int, Int)
15+countDownBench start = run . runState start $ countDownPut
16+
17+countDownExcBench :: Int -> Either String (Int, Int)
18+countDownExcBench start = run . runError . runState start $ countDownExc
19+
20+httpBench :: Int -> IO Int
21+httpBench n = runHttp (doHTTP n)
instances/Fused/HTTP.hs+35−41
@@ -1,53 +1,47 @@
1−{-# LANGUAGE TypeOperators, FlexibleInstances, KindSignatures, MultiParamTypeClasses, DeriveFunctor, UndecidableInstances, GeneralizedNewtypeDeriving #-}
2−
3module Fused.HTTP where
1module Fused.HTTP where
4
2
5−import Control.Effect
3+import Control.Algebra
6−import Control.Effect.Sum
7−import Control.Effect.Carrier
4+import Control.Carrier.Lift
8−import Data.Coerce
5+import Control.Monad
9import Control.Monad.IO.Class
6import Control.Monad.IO.Class
7+import Data.Functor
8+import GHC.Generics (Generic1)
10
9
11−newtype HttpC m a = HttpC { runHttpC :: m a }
10+newtype HttpC m a = HttpC {runHttpC :: m a}
12− deriving (Applicative, Functor, Monad, MonadIO)
11+ deriving newtype (Applicative, Functor, Monad, MonadIO)
13−
14−data HTTP (m :: * -> *) k
15− = Open String k
16− | Close k
17− | Post String (String -> k)
18− | HGet (String -> k)
19− deriving Functor
20−
21−instance Effect HTTP where
22− handle state handler (Open s k) = Open s (handler . (<$ state) $ k)
23− handle state handler (Close k) = Close (handler . (<$ state) $ k)
24− handle state handler (Post s k) = Post s (handler . (<$ state) . k)
25− handle state handler (HGet k) = HGet (handler . (<$ state) . k)
26
12
27−instance HFunctor HTTP where
13+data HTTP (m :: * -> *) k where
28− hmap _ = coerce
14+ Open :: String -> HTTP m ()
15+ Close :: HTTP m ()
16+ Post :: String -> HTTP m String
17+ HGet :: HTTP m String
29
18
30−open' :: String -> HttpM ()
19+open' :: Has HTTP sig m => String -> m ()
31−open' s = send (Open s (pure ()))
20+open' s = send (Open s)
32
21
33−close' :: HttpM ()
22+close' :: Has HTTP sig m => m ()
34−close' = send (Close (pure ()))
23+close' = send Close
35
24
36−post' :: String -> HttpM String
25+post' :: Has HTTP sig m => String -> m String
37−post' s = send (Post s pure)
26+post' s = send (Post s)
38
27
39−get' :: HttpM String
28+get' :: Has HTTP sig m => m String
40−get' = send (HGet pure)
29+get' = send HGet
41
30
42−type HttpM = HttpC (LiftC IO)
31+instance (Algebra sig m) => Algebra (HTTP :+: sig) (HttpC m) where
32+ alg hdl (L act) ctx = case act of
33+ Open _ -> pure ctx
34+ Close -> pure ctx
35+ Post s -> pure $ ctx $> ("posted " <> s)
36+ HGet -> pure $ ctx $> "lmao"
37+ alg hdl (R other) ctx = HttpC (alg (runHttpC . hdl) other ctx)
43
38
44−instance (Effect sig, Carrier sig m) => Carrier (HTTP :+: sig) (HttpC m) where
45− eff (L act) = case act of
46− Open _ k -> k
47− Close k -> k
48− Post s k -> k ("posted " <> s)
49− HGet k -> k "lmao"
50− eff (R other) = HttpC (eff (handleCoercible other))
51−
52−runHttp :: HttpM a -> IO a
39+runHttp :: HttpC (LiftC IO) a -> IO a
53runHttp = runM . runHttpC
40runHttp = runM . runHttpC
41+
42+doHTTP :: Has HTTP sig m => Int -> m Int
43+doHTTP n = do
44+ open' "cats"
45+ replicateM_ n (get' *> post' "cats")
46+ close'
47+ pure n
instances/Fused/Stateful.hs+3−14
@@ -1,17 +1,6 @@
1−{-# LANGUAGE TypeApplications #-}
2−
3module Fused.Stateful where
1module Fused.Stateful where
4
2
5−import Control.Effect (run, PureC)
3+import Control.Effect.State
6−import Control.Effect.State.Lazy as State
7−
8−type StateM = StateC Int PureC
9−
10−get :: StateM Int
11−get = State.get @Int
12−
13−put :: Int -> StateM ()
14−put = State.put @Int
15
4
16−runStateful :: Int -> StateM a -> (Int, a)
5+countDownPut :: Has (State Int) sig m => m Int
17−runStateful n x = run $ State.runState n x
6+countDownPut = get >>= (\n -> if n < 0 then pure n else put (n - 1) *> countDownPut)
instances/Fused/StatefulExcept.hs+4−17
@@ -1,21 +1,8 @@
1−{-# LANGUAGE TypeApplications #-}
2−
3module Fused.StatefulExcept where
1module Fused.StatefulExcept where
4
2
5−import Control.Effect (run, PureC)
6−import Control.Effect.State.Strict as State
7import Control.Effect.Error
3import Control.Effect.Error
4+import Control.Effect.State
8
5
9−type StateM = StateC Int (ErrorC String PureC)
6+countDownExc :: (Has (State Int) sig m, Has (Error String) sig m) => m a
10−
7+countDownExc =
11−get :: StateM Int
8+ get @Int >>= (\n -> if n <= 0 then throwError "what" else put @Int (n - 1) *> countDownExc)
12−get = State.get @Int
13−
14−put :: Int -> StateM ()
15−put = State.put @Int
16−
17−throw :: String -> StateM a
18−throw = throwError
19−
20−runStatefulExcept :: Int -> StateM a -> Either String (Int, a)
21−runStatefulExcept n x = run . runError $ State.runState n x
instances/MTL/Bench.hsnew file+21
@@ -0,0 +1,21 @@
1+module MTL.Bench
2+ ( countDownBench,
3+ countDownExcBench,
4+ httpBench,
5+ )
6+where
7+
8+import Control.Monad.Except
9+import Control.Monad.State.Strict
10+import MTL.HTTP
11+import MTL.Stateful
12+import MTL.StatefulExcept
13+
14+countDownBench :: Int -> (Int, Int)
15+countDownBench start = flip runState start $ countDownPut
16+
17+countDownExcBench :: Int -> Either String (Int, Int)
18+countDownExcBench start = runExcept . flip runStateT start $ countDownExc
19+
20+httpBench :: Int -> IO Int
21+httpBench n = runHttp (doHTTP n)
instances/MTL/HTTP.hs+14−9
@@ -1,5 +1,3 @@
1−{-# LANGUAGE GADTs, LambdaCase #-}
2−
3module MTL.HTTP where
1module MTL.HTTP where
4
2
5import Control.Applicative
3import Control.Applicative
@@ -18,7 +16,7 @@ instance Functor HttpM where
18 fmap = liftA
16 fmap = liftA
19
17
20instance Applicative HttpM where
18instance Applicative HttpM where
21− pure = Pure
19+ pure = Pure
22 (<*>) = ap
20 (<*>) = ap
23
21
24instance Monad HttpM where
22instance Monad HttpM where
@@ -38,10 +36,17 @@ open' = Open
38
36
39runHttp :: HttpM a -> IO a
37runHttp :: HttpM a -> IO a
40runHttp = \case
38runHttp = \case
41− Pure x -> pure x
39+ Pure x -> pure x
42− Lift m -> m
40+ Lift m -> m
43 Then x f -> runHttp x >>= runHttp . f
41 Then x f -> runHttp x >>= runHttp . f
44− Open _ -> pure ()
42+ Open _ -> pure ()
45− Shut -> pure ()
43+ Shut -> pure ()
46− Post s -> pure ("posted " <> s)
44+ Post s -> pure ("posted " <> s)
47− HGet -> pure "lmap"
45+ HGet -> pure "lmap"
46+
47+doHTTP :: Int -> HttpM Int
48+doHTTP n = do
49+ open' "cats"
50+ replicateM_ n (get' *> post' "cats")
51+ close'
52+ pure n
instances/MTL/Stateful.hsnew file+6
@@ -0,0 +1,6 @@
1+module MTL.Stateful where
2+
3+import Control.Monad.State.Class
4+
5+countDownPut :: MonadState Int m => m Int
6+countDownPut = get >>= (\n -> if n < 0 then pure n else put (n - 1) *> countDownPut)
instances/MTL/StatefulExcept.hs+4−17
@@ -1,20 +1,7 @@
1module MTL.StatefulExcept where
1module MTL.StatefulExcept where
2
2
3+import Control.Monad.Error.Class
3−import qualified Control.Monad.State.Strict as MTL
4+import Control.Monad.State.Class
4−import qualified Control.Monad.Except as MTL
5−import Data.Tuple
6−import Data.Functor.Identity
7
5
8−type StateM = MTL.StateT Int (MTL.ExceptT String Identity)
6+countDownExc :: (MonadState Int m, MonadError String m) => m a
9−
7+countDownExc = get >>= (\n -> if n <= 0 then throwError "what" else put (n - 1) *> countDownExc)
10−get :: StateM Int
11−get = MTL.get
12−
13−put :: Int -> StateM ()
14−put = MTL.put
15−
16−throw :: String -> StateM a
17−throw = MTL.throwError
18−
19−runStatefulExcept :: Int -> StateM a -> Either String (Int, a)
20−runStatefulExcept n x = fmap swap . MTL.runExcept $ MTL.runStateT x n
instances/MTLStateful.hsdeleted−16
@@ -1,16 +0,0 @@
1−module MTLStateful where
2−
3−import qualified Control.Monad.State.Strict as MTL
4−import Data.Tuple
5−import Data.Functor.Identity
6−
7−type StateM = MTL.StateT Int Identity
8−
9−get :: StateM Int
10−get = MTL.get
11−
12−put :: Int -> StateM ()
13−put = MTL.put
14−
15−runStateful :: Int -> StateM a -> (Int, a)
16−runStateful n x = swap (MTL.runState x n)
instances/PStateful.hsdeleted−17
@@ -1,17 +0,0 @@
1−{-# LANGUAGE TypeApplications, DataKinds #-}
2−
3−module PStateful where
4−
5−import Polysemy
6−import Polysemy.State as State
7−
8−type StateM = Sem '[State Int]
9−
10−get :: StateM Int
11−get = State.get
12−
13−put :: Int -> StateM ()
14−put = State.put
15−
16−runStateful :: Int -> StateM a -> (Int, a)
17−runStateful n x = run $ State.runState n x
instances/Poly/Bench.hsnew file+22
@@ -0,0 +1,22 @@
1+module Poly.Bench
2+ ( countDownBench,
3+ countDownExcBench,
4+ httpBench,
5+ )
6+where
7+
8+import Poly.HTTP
9+import Poly.Stateful
10+import Poly.StatefulExcept
11+import Polysemy
12+import Polysemy.Error
13+import Polysemy.State
14+
15+countDownBench :: Int -> (Int, Int)
16+countDownBench start = run . runState start $ countDownPut
17+
18+countDownExcBench :: Int -> Either String (Int, Int)
19+countDownExcBench start = run . runError . runState start $ countDownExc
20+
21+httpBench :: Int -> IO Int
22+httpBench n = runHttp (doHTTP n)
instances/Poly/HTTP.hs+21−37
@@ -1,61 +1,45 @@
1−{-# LANGUAGE DataKinds, TemplateHaskell, KindSignatures, GADTs, FlexibleContexts, TypeOperators, LambdaCase #-}
1+{-# LANGUAGE TemplateHaskell #-}
2
2
3module Poly.HTTP where
3module Poly.HTTP where
4
4
5+import Control.Monad
5import Polysemy
6import Polysemy
6
7
7−type HttpM = Sem '[Http, Lift IO]
8+type HttpM = Sem '[Http, Final IO]
8
9
9data Http (m :: * -> *) a where
10data Http (m :: * -> *) a where
10− HOpen :: String -> Http m ()
11+ HOpen :: String -> Http m ()
11 HClose :: Http m ()
12 HClose :: Http m ()
12− HPost :: String -> Http m String
13+ HPost :: String -> Http m String
13− HGet :: Http m String
14+ HGet :: Http m String
14
15
15makeSem ''Http
16makeSem ''Http
16
17
17−open' :: String -> HttpM ()
18+open' :: Member Http r => String -> Sem r ()
18−open' = hOpen
19+open' = hOpen
19
20
20−close' :: HttpM ()
21+close' :: Member Http r => Sem r ()
21close' = hClose
22close' = hClose
22
23
23−post' :: String -> HttpM String
24+post' :: Member Http r => String -> Sem r String
24post' = hPost
25post' = hPost
25
26
26−get' :: HttpM String
27+get' :: Member Http r => Sem r String
27get' = hGet
28get' = hGet
28
29
29runHttp' :: Sem (Http ': r) a -> Sem r a
30runHttp' :: Sem (Http ': r) a -> Sem r a
30runHttp' = interpret $ \case
31runHttp' = interpret $ \case
31 HOpen _ -> pure ()
32 HOpen _ -> pure ()
32− HClose -> pure ()
33+ HClose -> pure ()
33 HPost s -> pure ("posted " <> s)
34 HPost s -> pure ("posted " <> s)
34− HGet -> pure "contents"
35+ HGet -> pure "contents"
35
36
36runHttp :: HttpM a -> IO a
37runHttp :: HttpM a -> IO a
37−runHttp = runM . runHttp'
38+runHttp = runFinal . runHttp'
38−
39+
39−-- open' :: String -> HttpM ()
40+doHTTP :: Member Http r => Int -> Sem r Int
40−-- open' = send . Open
41+doHTTP n = do
41−
42+ open' "cats"
42−-- close' :: HttpM ()
43+ replicateM_ n (get' *> post' "cats")
43−-- close' = send Close
44+ close'
44−
45+ pure n
45−-- post' :: String -> HttpM String
46−-- post' = send . Post
47−
48−-- get' :: HttpM String
49−-- get' = send Get
50−
51−-- runHttp' :: Eff (Http ': r) w -> Eff r w
52−-- runHttp' (Val x) = pure x
53−-- runHttp' (E u q) = case decomp u of
54−-- Right (Open _) -> runHttp (qApp q ())
55−-- Right Close -> runHttp (qApp q ())
56−-- Right (Post d) -> runHttp (qApp q d)
57−-- Right Get -> runHttp (qApp q "")
58−-- Left u' -> E u' (tsingleton (runHttp . qApp q ))
59−
60−-- runHttp :: HttpM a -> IO a
61−-- runHttp = runM . runHttp'
instances/Poly/Stateful.hs+3−13
@@ -1,17 +1,7 @@
1−{-# LANGUAGE DataKinds, TypeApplications #-}
2−
3module Poly.Stateful where
1module Poly.Stateful where
4
2
5import Polysemy
3import Polysemy
6−import Polysemy.State as State
4+import Polysemy.State
7−
8−type StateM = Sem '[State Int]
9−
10−get :: StateM Int
11−get = State.get @Int
12−
13−put :: Int -> StateM ()
14−put = State.put @Int
15
5
16−runStateful :: Int -> StateM a -> (Int, a)
6+countDownPut :: Member (State Int) r => Sem r Int
17−runStateful n x = run $ State.runState n x
7+countDownPut = get >>= (\n -> if n < 0 then pure n else put (n - 1) *> countDownPut)
instances/Poly/StatefulExcept.hs+4−16
@@ -1,20 +1,8 @@
1−{-# LANGUAGE TypeApplications, DataKinds #-}
2module Poly.StatefulExcept where
1module Poly.StatefulExcept where
3
2
4import Polysemy
3import Polysemy
5−import Polysemy.State as State
4+import Polysemy.Error
6−import Polysemy.Error as Err
5+import Polysemy.State
7
6
8−type StateM = Sem '[State Int, Error String]
7+countDownExc :: (Member (State Int) r, Member (Error String) r) => Sem r a
9−
8+countDownExc = get @Int >>= (\n -> if n <= 0 then throw "what" else put @Int (n - 1) *> countDownExc)
10−get :: StateM Int
11−get = State.get @Int
12−
13−put :: Int -> StateM ()
14−put = State.put @Int
15−
16−throw :: String -> StateM a
17−throw = Err.throw
18−
19−runStatefulExcept :: Int -> StateM a -> Either String (Int, a)
20−runStatefulExcept n x = run . runError $ State.runState n x
instances/Shallow/Bench.hsnew file+19
@@ -0,0 +1,19 @@
1+module Shallow.Bench
2+ ( countDownBench,
3+ countDownExcBench,
4+ httpBench,
5+ )
6+where
7+
8+import Shallow.HTTP
9+import Shallow.Stateful
10+import Shallow.StatefulExcept
11+
12+countDownBench :: Int -> (Int, Int)
13+countDownBench = countDownPut
14+
15+countDownExcBench :: Int -> Either String (Int, Int)
16+countDownExcBench = countDownExc
17+
18+httpBench :: Int -> IO Int
19+httpBench = doHTTP
instances/Shallow/HTTP.hs+11−4
@@ -1,9 +1,9 @@
1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2−
3module Shallow.HTTP where
1module Shallow.HTTP where
4
2
3+import Control.Monad
4+
5−newtype HttpM a = HttpM { runHttp :: IO a}
5+newtype HttpM a = HttpM {runHttp :: IO a}
6− deriving (Applicative, Functor, Monad)
6+ deriving newtype (Applicative, Functor, Monad)
7
7
8get' :: HttpM String
8get' :: HttpM String
9get' = pure "lmao"
9get' = pure "lmao"
@@ -16,3 +16,10 @@ close' = pure ()
16
16
17open' :: String -> HttpM ()
17open' :: String -> HttpM ()
18open' _ = pure ()
18open' _ = pure ()
19+
20+doHTTP :: Int -> IO Int
21+doHTTP n = runHttp $ do
22+ open' "cats"
23+ replicateM_ n (get' *> post' "cats")
24+ close'
25+ pure n
instances/Shallow/Stateful.hs+6−1
@@ -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))
@@ -22,3 +22,8 @@ put x = StateM (\_ -> (x, ()))
22
22
23runStateful :: Int -> StateM a -> (Int, a)
23runStateful :: Int -> StateM a -> (Int, a)
24runStateful n (StateM f) = f $! n
24runStateful n (StateM f) = f $! n
25+
26+countDownPut :: Int -> (Int, Int)
27+countDownPut start = runStateful start go
28+ where
29+ go = get >>= (\n -> if n < 0 then pure n else put (n - 1) *> go)
instances/Shallow/StatefulExcept.hs+12−6
@@ -1,10 +1,8 @@
1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2−
3module Shallow.StatefulExcept where
1module Shallow.StatefulExcept where
4
2
5import Control.Monad
3import Control.Monad
6
4
7−newtype StateM a = StateM { unStateM :: Int -> Either String (Int, a) }
5+newtype StateM a = StateM {unStateM :: Int -> Either String (Int, a)}
8
6
9instance Functor StateM where
7instance Functor StateM where
10 fmap f (StateM a) = StateM (\n -> fmap (fmap f) (a n))
8 fmap f (StateM a) = StateM (\n -> fmap (fmap f) (a n))
@@ -14,9 +12,12 @@ instance Applicative StateM where
14 (<*>) = ap
12 (<*>) = ap
15
13
16instance Monad StateM where
14instance Monad StateM where
15+ (StateM a) >>= f =
16+ StateM
17− (StateM a) >>= f = StateM (\n -> case a n of
17+ ( \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+ )
20
21
21get :: StateM Int
22get :: StateM Int
22get = StateM (\n -> Right (n, n))
23get = StateM (\n -> Right (n, n))
@@ -29,3 +30,8 @@ throw s = StateM (\_ -> Left s)
29
30
30runStatefulExcept :: Int -> StateM a -> Either String (Int, a)
31runStatefulExcept :: Int -> StateM a -> Either String (Int, a)
31runStatefulExcept n (StateM f) = f $! n
32runStatefulExcept n (StateM f) = f $! n
33+
34+countDownExc :: Int -> Either String (Int, Int)
35+countDownExc start = runStatefulExcept start go
36+ where
37+ go = get >>= (\n -> if n <= 0 then throw "what" else put (n - 1) *> go)
package.yamlnew file+37
@@ -0,0 +1,37 @@
1+name: effects-benchmarks
2+
3+benchmarks:
4+ effects-benchmarks:
5+ main: Main.hs
6+ dependencies:
7+ - base
8+ - polysemy
9+ - freer-simple
10+ - fused-effects
11+ - mtl
12+ - extensible-effects
13+ - gauge
14+ - weigh
15+ - effectful
16+ - effectful-core
17+ source-dirs:
18+ - instances
19+ - 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/Bench/Countdown.hsdeleted−14
@@ -1,14 +0,0 @@
1−{-# LANGUAGE FlexibleContexts #-}
2−
3−module Bench.Countdown where
4−
5−import qualified Bench.Signature.Stateful as S
6−import qualified Bench.Signature.StatefulExcept as SE
7−
8−countDownPut :: Int -> (Int, Int)
9−countDownPut start = S.runStateful start go where
10− go = S.get >>= (\n -> if n < 0 then pure n else S.put (n - 1) *> go)
11−
12−countDownExc :: Int -> Either String (Int, Int)
13−countDownExc start = SE.runStatefulExcept start go where
14− go = SE.get >>= (\n -> if n <= 0 then SE.throw "what" else SE.put (n - 1) *> go)
src/Bench/HTTP.hsdeleted−11
@@ -1,11 +0,0 @@
1−module Bench.HTTP where
2−
3−import Bench.Signature.HTTP
4−import Control.Monad
5−
6−doHTTP :: Int -> IO Int
7−doHTTP n = runHttp $ do
8− open' "cats"
9− replicateM_ n (get' *> post' "cats")
10− close'
11− pure n
src/Bench/Signature/HTTP.hsigdeleted−19
@@ -1,19 +0,0 @@
1−signature Bench.Signature.HTTP
2− ( HttpM
3− , open'
4− , close'
5− , post'
6− , get'
7− , runHttp
8− ) where
9−
10−data HttpM a
11−
12−instance Applicative HttpM
13−instance Monad HttpM
14−
15−open' :: String -> HttpM ()
16−get' :: HttpM String
17−post' :: String -> HttpM String
18−close' :: HttpM ()
19−runHttp :: HttpM a -> IO a
src/Bench/Signature/Stateful.hsigdeleted−17
@@ -1,17 +0,0 @@
1−{-# LANGUAGE KindSignatures #-}
2−signature Bench.Signature.Stateful
3− ( StateM
4− , get
5− , put
6− , runStateful
7− ) where
8−
9−data StateM a
10−
11−instance Applicative StateM
12−instance Monad StateM
13−
14−get :: StateM Int
15−put :: Int -> StateM ()
16−runStateful :: Int -> StateM a -> (Int, a)
17−
src/Bench/Signature/StatefulExcept.hsigdeleted−17
@@ -1,17 +0,0 @@
1−signature Bench.Signature.StatefulExcept
2− ( StateM
3− , get
4− , put
5− , throw
6− , runStatefulExcept
7− ) where
8−
9−data StateM a
10−
11−instance Applicative StateM
12−instance Monad StateM
13−
14−get :: StateM Int
15−put :: Int -> StateM ()
16−throw :: String -> StateM a
17−runStatefulExcept :: Int -> StateM a -> Either String (Int, a)
src/FreerSimple.hsdeleted−73
@@ -1,73 +0,0 @@
1−{-# LANGUAGE TypeOperators, GADTs, FlexibleContexts, DataKinds #-}
2−
3−module FreerSimple (marks) where
4−
5−import Control.Monad
6−import Control.Monad.Freer
7−import Control.Monad.Freer.State
8−import Control.Monad.Freer.Error
9−import Gauge
10−
11−data HTTP a where
12− Open :: String -> HTTP ()
13− Close :: HTTP ()
14− Post :: String -> HTTP String
15− HGet :: HTTP String
16−
17−open' :: Member HTTP r => String -> Eff r ()
18−open' = send . Open
19−
20−close' :: Member HTTP r => Eff r ()
21−close' = send Close
22−
23−post' :: Member HTTP r => String -> Eff r String
24−post' = send . Post
25−
26−get' :: Member HTTP r => Eff r String
27−get' = send HGet
28−
29−runHTTP :: Eff (HTTP ': e) b -> Eff e b
30−runHTTP = interpret
31− (\x -> case x of
32− Open _ -> pure ()
33− Close -> pure ()
34− Post a -> pure a
35− HGet -> pure "gotten")
36−
37−prog :: Member HTTP r => Eff r ()
38−prog = open' "cats" >> get' >> post' "cats" >> close'
39−
40−p :: Member HTTP r => Int -> Eff r ()
41−p count = open' "cats" >> replicateM_ count (get' >> post' "cats") >> close'
42−
43−oneGet :: Int -> (Int, Int)
44−oneGet n = run (runState n get)
45−
46−countDown :: Int -> (Int,Int)
47−countDown start = run (runState start go)
48− where go = get >>= (\n -> if n <= 0 then pure n else put (n-1) >> go)
49−
50−countDownExc :: Int -> Either String (Int,Int)
51−countDownExc start = run $ runError (runState start go)
52− where go = get >>= (\n -> if n <= (0 :: Int) then throwError "wat" else put (n-1) >> go)
53−
54−-- prog :: (Monad m, Member HTTP sig, Carrier sig m) => m ()
55−-- prog = open' "cats" >> get' >> post' "cats" >> close'
56−
57−-- p :: (Monad m, Member HTTP sig, Carrier sig m) => Int -> m ()
58−-- p count = open' "cats" >> replicateM_ count (get' >> post' "cats") >> close'
59−
60−marks :: Benchmark
61−marks = bgroup "freer-simple"
62− [ bgroup "State"
63− [ bench "get" $ whnf oneGet 0
64− , bench "countdown" $ whnf countDown 100
65− ]
66− , bgroup "State + Error"
67− [ bench "countdownExc" $ whnf countDownExc 10000
68− ]
69− , bgroup "HTTP DSL"
70− [ bench "simple" $ whnf (run . runHTTP) prog
71− , bench "replicated" $ whnf (run . runHTTP . p) 100000
72− ]
73− ]
src/HigherOrder.hsdeleted−76
@@ -1,76 +0,0 @@
1−{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses,
2− TypeApplications, TypeOperators, UndecidableInstances #-}
3−
4−module HigherOrder (marks) where
5−
6−import Control.Effect
7−import Control.Monad
8−import Data.Coerce
9−import Gauge.Main
10−
11−data HTTP (m :: * -> *) k
12− = Open String k
13− | Close k
14− | Post String (String -> k)
15− | HGet (String -> k)
16− deriving Functor
17−
18−instance HFunctor HTTP where
19− hmap _ = coerce
20−
21−open' :: (Member HTTP sig, Carrier sig m) => String -> m ()
22−open' s = send (Open s (gen ()))
23−
24−close' :: (Member HTTP sig, Carrier sig m) => m ()
25−close' = send (Close (gen ()))
26−
27−post' :: (Member HTTP sig, Carrier sig m) => String -> m String
28−post' s = send (Post s gen)
29−
30−get' :: (Member HTTP sig, Carrier sig m) => m String
31−get' = send (HGet gen)
32−
33−newtype HTTPC m a = HTTPC { runHTTPC :: m a }
34−
35−instance (Carrier sig m) => Carrier (HTTP :+: sig) (HTTPC m) where
36− gen = HTTPC . gen
37− alg = algS \/ (HTTPC . alg . handlePure runHTTPC) where
38− algS (Open _ k) = k
39− algS (Close k) = k
40− algS (Post s k) = k s
41− algS (HGet k) = k ""
42−
43−runHTTP :: (Carrier sig m) => Eff (HTTPC m) a -> m a
44−runHTTP = runHTTPC . interpret
45−
46−oneGet :: Int -> (Int, Int)
47−oneGet n = run (runState n get)
48−
49−countDown :: Int -> (Int,Int)
50−countDown start = run (runState start go)
51− where go = get >>= (\n -> if n <= 0 then pure n else put (n-1) >> go)
52−
53−countDownExc :: Int -> Either String (Int,Int)
54−countDownExc start = run $ runError (runState start go)
55− where go = get >>= (\n -> if n <= (0 :: Int) then throwError "wat" else put (n-1) >> go)
56−
57−prog :: (Monad m, Member HTTP sig, Carrier sig m) => m ()
58−prog = open' "cats" >> get' >> post' "cats" >> close'
59−
60−p :: (Monad m, Member HTTP sig, Carrier sig m) => Int -> m ()
61−p count = open' "cats" >> replicateM_ count (get' >> post' "cats") >> close'
62−
63−marks :: Benchmark
64−marks = bgroup "higher-order-effects"
65− [ bgroup "State"
66− [ bench "get" $ whnf oneGet 0
67− , bench "countdown" $ whnf countDown 100
68− ]
69− , bgroup "State + Error"
70− [ bench "countdownExc" $ whnf countDownExc 10000
71− ]
72− , bgroup "HTTP DSL"
73− [ bench "simple" $ whnf (run . runHTTP) prog
74− , bench "replicated" $ whnf (run . runHTTP . p) 100000
75− ]
76− ]
src/JVEffects.hsdeleted−72
@@ -1,72 +0,0 @@
1−{-# LANGUAGE TypeApplications, KindSignatures, TypeOperators, GADTs, FlexibleContexts, DataKinds #-}
2−
3−module JVEffects (marks) where
4−
5−import Control.Monad
6−import Control.Monad.Effect
7−import Control.Monad.Effect.Exception
8−import Control.Monad.Effect.State
9−import Gauge
10−
11−oneGet :: Int -> (Int, Int)
12−oneGet n = run @Eff (runState n get)
13−
14−countDown :: Int -> (Int,Int)
15−countDown start = run @Eff (runState start go)
16− where go = get >>= (\n -> if n <= 0 then pure n else put (n-1) >> go)
17−
18−countDownExc :: Int -> Either String (Int,Int)
19−countDownExc start = run @Eff $ runError (runState start go)
20− where go = get >>= (\n -> if n <= (0 :: Int) then throwError "wat" else put (n-1) >> go)
21−
22−data HTTP (m :: * -> *) out where
23− Open :: String -> HTTP m ()
24− Close :: HTTP m ()
25− Post :: String -> HTTP m String
26− HGet :: HTTP m String
27−
28−instance Effect HTTP where
29− handleState _ _ _ = error "Rob said we didn't need this"
30−
31−instance PureEffect HTTP
32−
33−open' :: Member HTTP r => String -> Eff r ()
34−open' = send . Open
35−
36−close' :: Member HTTP r => Eff r ()
37−close' = send Close
38−
39−post' :: Member HTTP r => String -> Eff r String
40−post' = send . Post
41−
42−get' :: Member HTTP r => Eff r String
43−get' = send HGet
44−
45−runHTTP :: PureEffects e => Eff (HTTP ': e) b -> Eff e b
46−runHTTP = interpret
47− (\x -> case x of
48− Open _ -> pure ()
49− Close -> pure ()
50− Post a -> pure a
51− HGet -> pure "gotten")
52−
53−prog :: Member HTTP r => Eff r ()
54−prog = open' "cats" >> get' >> post' "cats" >> close'
55−
56−p :: Member HTTP r => Int -> Eff r ()
57−p count = open' "cats" >> replicateM_ count (get' >> post' "cats") >> close'
58−
59−marks :: Benchmark
60−marks = bgroup "joshvera/effects"
61− [ bgroup "State"
62− [ bench "get" $ whnf oneGet 0
63− , bench "countdown" $ whnf countDown 100
64− ]
65− , bgroup "State + Error"
66− [ bench "countdownExc" $ whnf countDownExc 10000
67− ]
68− , bgroup "HTTP DSL"
69− [ bench "simple" $ whnf (run . runHTTP) prog
70− , bench "replicated" $ whnf (run . runHTTP . p) 100000
71− ]
72− ]
src/MTL.hsdeleted−27
@@ -1,27 +0,0 @@
1−module MTL (marks) where
2−
3−import qualified Control.Monad.State as MTL
4−import qualified Control.Monad.Except as MTL
5−import Gauge
6−
7−oneGet :: Int -> (Int, Int)
8−oneGet = MTL.runState MTL.get
9−
10−countDown :: Int -> (Int,Int)
11−countDown = MTL.runState go
12− where go = MTL.get >>= (\n -> if n <= 0 then pure n else MTL.put (n-1) >> go)
13−
14−countDownExc :: Int -> Either String (Int,Int)
15−countDownExc = MTL.runStateT go
16− where go = MTL.get >>= (\n -> if n <= (0 :: Int) then MTL.throwError "wat" else MTL.put (n-1) >> go)
17−
18−marks :: Benchmark
19−marks = bgroup "MTL"
20− [ bgroup "State"
21− [ bench "get" $ whnf oneGet 0
22− , bench "countdown" $ whnf countDown 100
23− ]
24− , bgroup "State + Error"
25− [ bench "countdownExc" $ whnf countDownExc 10000
26− ]
27− ]
src/Main.hs+70−46
@@ -1,66 +1,90 @@
1+{-# LANGUAGE CPP #-}
1−{-# LANGUAGE FlexibleContexts, GADTs, CPP #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE GADTs #-}
2
4
3module Main where
5module Main where
4
6
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
5import Gauge (bench, bgroup, nf, nfAppIO)
12import Gauge (bench, bgroup, nf, nfAppIO)
6import Gauge.Main (defaultMain)
13import Gauge.Main (defaultMain)
14+import qualified MTL.Bench as MTL
15+import qualified Poly.Bench as Poly
16+import qualified Shallow.Bench as Shallow
7import qualified Weigh
17import qualified Weigh
8
18
9−import qualified Fused.Countdown as Fused
10−import qualified Simple.Countdown as Simple
11−import qualified Shallow.Countdown as Shallow
12−import qualified MTL.Countdown as MTL
13−import qualified Poly.Countdown as Poly
14−import qualified ExtEff.Countdown as ExtEff
15−
16−import qualified Fused.HTTPM as Fused
17−import qualified Simple.HTTPM as Simple
18−import qualified MTL.HTTPM as MTL
19−import qualified Shallow.HTTPM as Shallow
20−import qualified Poly.HTTPM as Poly
21−import qualified ExtEff.HTTPM as ExtEff
22−
23−#define MEMSUITE(nam,v) sequence_ [ Weigh.func "fused-effects" Fused.nam v \
24− , Weigh.func "mtl" MTL.nam v \
25− , Weigh.func "polysemy" Poly.nam v \
26− , Weigh.func "freer-simple" Simple.nam v \
27− , Weigh.func "extensible-effects" ExtEff.nam v \
28− , Weigh.func "shallow" Shallow.nam v ]
29−
30−#define SUITE(nam,v) [ bench "fused-effects" (nf Fused.nam v) \
31− , bench "mtl" (nf MTL.nam v) \
32− , bench "polysemy" (nf Poly.nam v) \
33− , bench "freer-simple" (nf Simple.nam v) \
34− , bench "extensible-effects" (nf ExtEff.nam v) \
35− , bench "shallow" (nf Shallow.nam v) ]
36−
37wruns :: Int
19wruns :: Int
38wruns = 1
20wruns = 1
39
21
40runs :: Int
22runs :: Int
41−runs = 10000
23+runs = 100000
42
24
43main :: IO ()
25main :: IO ()
44main = do
26main = do
45 putStrLn "*** Time benchmarks ***"
27 putStrLn "*** Time benchmarks ***"
46 defaultMain
28 defaultMain
47− [
29+ [ bgroup
48− bgroup "Countdown"
30+ "Countdown"
49− [ bgroup "Put" SUITE(countDownPut, runs)
31+ [ bgroup
50− , bgroup "Put+Exc" SUITE(countDownExc, runs)
32+ "Put"
33+ [ bench "fused-effects" (nf Fused.countDownBench runs),
34+ bench "mtl" (nf MTL.countDownBench runs),
35+ bench "polysemy" (nf Poly.countDownBench runs),
36+ 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),
49+ bench "shallow" (nf Shallow.countDownExcBench runs),
50+ bench "effectful - static" (nf EffectfulStatic.countDownExcBench runs),
51+ bench "effectful - dynamic" (nf EffectfulDynamic.countDownExcBench runs)
51− ]
52+ ]
53+ ],
52− , bgroup "HTTP"
54+ bgroup
55+ "HTTP"
53− [ bench "fused-effects" (nfAppIO Fused.doHTTP runs)
56+ [ bench "fused-effects" (nfAppIO Fused.httpBench runs),
54− , bench "polysemy" (nfAppIO Poly.doHTTP runs)
57+ bench "polysemy" (nfAppIO Poly.httpBench runs),
55− , bench "extensible-effects" (nfAppIO ExtEff.doHTTP runs)
58+ bench "extensible-effects" (nfAppIO ExtEff.httpBench runs),
56− , bench "Deep embedding" (nfAppIO MTL.doHTTP runs)
59+ bench "Deep embedding" (nfAppIO MTL.httpBench runs),
57− , bench "Shallow embedding" (nfAppIO Shallow.doHTTP runs)
60+ bench "Shallow embedding" (nfAppIO Shallow.httpBench runs),
58− , bench "freer-simple" (nfAppIO Simple.doHTTP 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)
59− ]
64+ ]
60 ]
65 ]
61
66
62 putStrLn "*** Space benchmarks (these will take some time to run) ***"
67 putStrLn "*** Space benchmarks (these will take some time to run) ***"
63 Weigh.mainWith $ do
68 Weigh.mainWith $ do
64− Weigh.wgroup "Countdown" $ MEMSUITE(countDownPut, wruns)
69+ Weigh.wgroup "Countdown" $
70+ sequence_
71+ [ Weigh.func "fused-effects" Fused.countDownBench wruns,
72+ Weigh.func "mtl" MTL.countDownBench wruns,
73+ Weigh.func "polysemy" Poly.countDownBench wruns,
74+ Weigh.func "freer-simple" Freer.countDownBench wruns,
75+ Weigh.func "extensible-effects" ExtEff.countDownBench wruns,
76+ Weigh.func "shallow" Shallow.countDownBench wruns,
77+ Weigh.func "effectful - static" EffectfulStatic.countDownBench runs,
78+ Weigh.func "effectful - dynamic" EffectfulDynamic.countDownBench runs
79+ ]
65− Weigh.wgroup "Countdown + exc" $ MEMSUITE(countDownExc, wruns)
80+ Weigh.wgroup "Countdown + exc" $
66−
81+ sequence_
82+ [ Weigh.func "fused-effects" Fused.countDownExcBench wruns,
83+ Weigh.func "mtl" MTL.countDownExcBench wruns,
84+ Weigh.func "polysemy" Poly.countDownExcBench wruns,
85+ Weigh.func "freer-simple" Freer.countDownExcBench wruns,
86+ Weigh.func "extensible-effects" ExtEff.countDownExcBench wruns,
87+ Weigh.func "shallow" Shallow.countDownExcBench wruns,
88+ Weigh.func "effectful - static" EffectfulStatic.countDownExcBench runs,
89+ Weigh.func "effectful - dynamic" EffectfulDynamic.countDownExcBench runs
90+ ]
stack.yamlnew file+78
@@ -0,0 +1,78 @@
1+# This file was automatically generated by 'stack init'
2+#
3+# Some commonly used options have been documented as comments in this file.
4+# For advanced use and comprehensive documentation of the format, please see:
5+# https://docs.haskellstack.org/en/stable/yaml_configuration/
6+
7+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
8+# A snapshot resolver dictates the compiler version and the set of packages
9+# to be used for project dependencies. For example:
10+#
11+# resolver: lts-3.5
12+# resolver: nightly-2015-09-21
13+# resolver: ghc-7.10.2
14+#
15+# The location of a snapshot can be provided as a file or url. Stack assumes
16+# a snapshot provided as a file might change, whereas a url resource does not.
17+#
18+# resolver: ./custom-snapshot.yaml
19+# resolver: https://example.com/snapshots/2018-01-01.yaml
20+resolver: lts-18.21
21+
22+# User packages to be built.
23+# Various formats can be used as shown in the example below.
24+#
25+# packages:
26+# - some-directory
27+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
28+# subdirs:
29+# - auto-update
30+# - wai
31+packages:
32+ - .
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
35+# forks / in-progress versions pinned to a git hash. For example:
36+#
37+# extra-deps:
38+# - acme-missiles-0.3
39+# - git: https://github.com/commercialhaskell/stack.git
40+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
41+#
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+
51+# Override default flag values for local packages and extra-deps
52+# flags: {}
53+
54+# Extra package databases containing global packages
55+# extra-package-dbs: []
56+
57+# Control whether we use the GHC we find on the path
58+# system-ghc: true
59+#
60+# Require a specific version of stack, using version ranges
61+# require-stack-version: -any # Default
62+# require-stack-version: ">=2.3"
63+#
64+# Override the architecture used by stack, especially useful on Windows
65+# arch: i386
66+# arch: x86_64
67+#
68+# Extra directories used by stack for building
69+# extra-include-dirs: [/path/to/dir]
70+# extra-lib-dirs: [/path/to/dir]
71+#
72+# Allow a newer minor version of GHC than the snapshot specifies
73+# compiler-check: newer-minor
74+
75+ghc-options:
76+ "$everything": -O2
77+
78+rebuild-ghc-options: true