Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 204 lines (180 sloc) 7.463 kB
57e7ad8 [t] move some junction tests
moritz authored
1 use v6;
2 use Test;
3
f914433 [t/spec] Various, though certainly not exhaustive, tests for auto-thr…
jnthn authored
4 plan 51;
57e7ad8 [t] move some junction tests
moritz authored
5
6 {
7 # Solves the equatioin A + B = A * C for integers
8 # by autothreading over all interesting values
9
10 my $n = 0;
11 sub is_it($a, $b, $c) {
12 $n++;
13 if ($a != $b && $b != $c && $a != $c &&
14 $a * 10 + $c == $a + $b ) {
15 return "$a + $b = $a$c";
16 } else {
17 return ();
18 }
19 }
20
21 # note that since the junction is not evaluated in boolean context,
22 # it's not collapsed, and the auto-threading may not abort prematurely
23 # when a result is found.
24 my $answer = is_it(any(1..2), any(7..9), any(0..6));
25 is($n, 42, "called lots of times :-)");
26
d11fdec [t/spec] avoid autothreading through ok() in three test files
moritz authored
27 ok( ?($answer eq "1 + 9 = 10"), "found right answer");
57e7ad8 [t] move some junction tests
moritz authored
28 }
29
5c2c4cd [t/spec] Few more tests for auto-threading, these ones covering auto-…
jnthn authored
30 {
31 # Checks auto-threading works on method calls too, and that we get the
32 # right result.
33 class Foo {
34 has $.count = 0;
35 method test($x) { $!count++; return $x }
36 }
37
38 my ($x, $r, $ok);
39 $x = Foo.new;
40 $r = $x.test(1|2);
41 is($x.count, 2, 'method called right number of times');
42 $ok = $r.perl.subst(/\D/, '', :g) eq '12' | '21';
43 ok(?$ok, 'right values passed to method');
44
45 $x = Foo.new;
46 $r = $x.test(1 & 2 | 3);
47 is($x.count, 3, 'method called right number of times');
48 $ok = $r.perl.subst(/\D/, '', :g) eq '123' | '213' | '312' | '321'; # e.g. & values together
49 ok(?$ok, 'junction structure maintained');
50 }
51
de5b1fb [t/spec] A bunch of tests for junctional dispatch with multi-subs (wi…
jnthn authored
52 {
53 # Check auto-threding works right on multi-subs.
54 my $calls_a = 0;
55 my $calls_b = 0;
56 my $calls_c = 0;
57 my ($r, $ok);
58 multi mstest(Int $x) { $calls_a++; return $x }
59 multi mstest(Str $x, Str $y) { $calls_b++ }
60 multi mstest(Str $x) { $calls_c++ }
61 $r = mstest(1&2 | 3);
62 is($calls_a, 3, 'correct multi-sub called right number of times');
63 is($calls_b, 0, 'incorrect multi-sub not called');
64 is($calls_c, 0, 'incorrect multi-sub not called');
65 $ok = $r.perl.subst(/\D/, '', :g) eq '123' | '213' | '312' | '321'; # e.g. & values together
66 ok(?$ok, 'junction structure maintained');
67
68 $calls_a = 0;
69 $calls_b = 0;
70 $calls_c = 0;
71 mstest("a" | "b", "c" & "d");
72 is($calls_b, 4, 'correct multi-sub called right number of times');
73 is($calls_a, 0, 'incorrect multi-sub not called');
74 is($calls_c, 0, 'incorrect multi-sub not called');
75
76 $calls_a = 0;
77 $calls_b = 0;
78 $calls_c = 0;
79 mstest('a' | 1 & 'b');
80 is($calls_a, 1, 'correct multi-sub called right number of times (junction of many types)');
81 is($calls_c, 2, 'correct multi-sub called right number of times (junction of many types)');
82 is($calls_b, 0, 'incorrect multi-sub not called');
83
84 # Extra sanity, in case some multi-dispatch caching issues existed.
85 $calls_a = 0;
86 $calls_b = 0;
87 $calls_c = 0;
88 mstest('a' | 1 & 'b');
89 is($calls_a, 1, 'correct multi-sub called again right number of times (junction of many types)');
90 is($calls_c, 2, 'correct multi-sub called again right number of times (junction of many types)');
91 is($calls_b, 0, 'incorrect multi-sub again not called');
92
93 $calls_a = 0;
94 $calls_b = 0;
95 $calls_c = 0;
96 mstest('a');
97 is($calls_a, 0, 'non-junctional dispatch still works');
98 is($calls_b, 0, 'non-junctional dispatch still works');
99 is($calls_c, 1, 'non-junctional dispatch still works');
100 }
5c2c4cd [t/spec] Few more tests for auto-threading, these ones covering auto-…
jnthn authored
101
de5b1fb [t/spec] A bunch of tests for junctional dispatch with multi-subs (wi…
jnthn authored
102 {
103 # Check auto-threading with multi-methods. Basically a re-hash of the
104 # above, but in a class.
105 class MMTest {
106 has $.calls_a = 0;
107 has $.calls_b = 0;
108 has $.calls_c = 0;
109 multi method mmtest(Int $x) { $!calls_a++; return $x }
110 multi method mmtest(Str $x, Str $y) { $!calls_b++ }
111 multi method mmtest(Str $x) { $!calls_c++ }
112 }
113 my ($obj, $r, $ok);
114 $obj = MMTest.new();
115 $r = $obj.mmtest(1&2 | 3);
116 is($obj.calls_a, 3, 'correct multi-method called right number of times');
117 is($obj.calls_b, 0, 'incorrect multi-method not called');
118 is($obj.calls_c, 0, 'incorrect multi-method not called');
119 $ok = $r.perl.subst(/\D/, '', :g) eq '123' | '213' | '312' | '321'; # e.g. & values together
120 ok(?$ok, 'junction structure maintained');
121
122 $obj = MMTest.new();
123 $obj.mmtest("a" | "b", "c" & "d");
124 is($obj.calls_b, 4, 'correct multi-method called right number of times');
125 is($obj.calls_a, 0, 'incorrect multi-method not called');
126 is($obj.calls_c, 0, 'incorrect multi-method not called');
127
128 $obj = MMTest.new();
129 $obj.mmtest('a' | 1 & 'b');
130 is($obj.calls_a, 1, 'correct multi-method called right number of times (junction of many types)');
131 is($obj.calls_c, 2, 'correct multi-method called right number of times (junction of many types)');
132 is($obj.calls_b, 0, 'incorrect multi-method not called');
133 }
62c7abe [t/spec] Tests for junction auto-threading and named parameters - fud…
jnthn authored
134
135 {
136 # Ensure named params in single dispatch auto-thread.
137 my $count = 0;
138 my @got;
139 sub nptest($a, :$b, :$c) { $count++; @got.push($a ~ $b ~ $c) }
140 my $r = nptest(1, c => 4|5, b => 2|3);
141 is($count, 4, 'auto-threaded over named parameters to call sub enough times');
142 @got .= sort;
143 is(@got.elems, 4, 'got array of right size to check what was called');
144 is(@got[0], '124', 'called with correct parameters');
145 is(@got[1], '125', 'called with correct parameters');
146 is(@got[2], '134', 'called with correct parameters');
147 is(@got[3], '135', 'called with correct parameters');
148 }
149
150 {
151 # Ensure named params in multi dispatch auto-thread.
152 my $count_a = 0;
153 my $count_b = 0;
154 my @got;
155 multi npmstest(Int $a, :$b, :$c) { $count_a++; @got.push($a ~ $b ~ $c) }
156 multi npmstest(Str $a, :$b, :$c) { $count_b++; @got.push($a ~ $b ~ $c) }
157 my $r = npmstest(1&'a', c => 2|3, b => 1);
158 is($count_a, 2, 'auto-threaded over named parameters to call multi-sub variant enough times');
159 is($count_b, 2, 'auto-threaded over named parameters to call multi-sub variant enough times');
160 @got .= sort;
161 is(@got.elems, 4, 'got array of right size to check what was called');
162 is(@got[0], '112', 'called with correct parameters');
163 is(@got[1], '113', 'called with correct parameters');
164 is(@got[2], 'a12', 'called with correct parameters');
165 is(@got[3], 'a13', 'called with correct parameters');
166 }
f914433 [t/spec] Various, though certainly not exhaustive, tests for auto-thr…
jnthn authored
167
168 {
169 # Auto-threading over an invocant.
170 class JuncInvTest1 {
171 my $.cnt is rw = 0;
172 method a { $.cnt++; }
173 has $.n;
174 method d { 2 * $.n }
175 }
176 class JuncInvTest2 {
177 my $.cnt is rw = 0;
178 method a { $.cnt++; }
179 method b($x) { $.cnt++ }
180 }
181
182 my $x = JuncInvTest1.new | JuncInvTest1.new | JuncInvTest2.new;
183 $x.a;
184 is JuncInvTest1.cnt, 2, 'basic auto-threading over invocant works';
185 is JuncInvTest2.cnt, 1, 'basic auto-threading over invocant works';
186
187 JuncInvTest1.cnt = 0;
188 JuncInvTest2.cnt = 0;
189 $x = JuncInvTest1.new | JuncInvTest2.new & JuncInvTest2.new;
190 $x.a;
191 is JuncInvTest1.cnt, 1, 'auto-threading over invocant of nested junctions works';
192 is JuncInvTest2.cnt, 2, 'auto-threading over invocant of nested junctions works';
193
194 $x = JuncInvTest1.new(n => 1) | JuncInvTest1.new(n => 2) & JuncInvTest1.new(n => 4);
195 my $r = $x.d;
196 my $ok = $r.perl.subst(/\D/, '', :g) eq '248' | '284' | '482' | '842';
197 ok($ok, 'auto-threading over invocant produced correct junctional result');
198
199 JuncInvTest2.cnt = 0;
200 $x = JuncInvTest2.new | JuncInvTest2.new;
201 $x.b('a' | 'b' | 'c');
202 is JuncInvTest2.cnt, 6, 'auto-threading over invocant and parameters works';
203 }
Something went wrong with that request. Please try again.