Skip to content
Newer
Older
100644 333 lines (247 sloc) 10.1 KB
82ba44c [spec] started to move junction tests (and upate POD). Much more work…
moritz authored
1 use v6;
2
3 use Test;
4
57e7ad8 [t] move some junction tests
moritz authored
5 plan 78;
82ba44c [spec] started to move junction tests (and upate POD). Much more work…
moritz authored
6
7 =begin pod
8
9 Misc. Junction tests
10
11 =end pod
12
13 # L<S03/Junctive operators>
14 # L<S09/Junctions>
15 {
16
17 # initalize them all to empty strings
18 my $a = '';
19 my $b = '';
20 my $c = '';
21
22 # make sure they all match to an empty string
23 ok('' eq ($a & $b & $c), 'junction of ($a & $b & $c) matches an empty string');
24 ok('' eq all($a, $b, $c), 'junction of all($a, $b, $c) matches an empty string');
25
26 # give $a a value
27 $a = 'a';
28
29 # make sure that at least one of them matches 'a'
30 ok('a' eq ($b | $c | $a), 'junction of ($b | $c | $a) matches at least one "a"');
31 ok('a' eq any($b, $c, $a), 'junction of any($b, $c, $a) matches at least one "a"');
32
33 ok('' eq ($b | $c | $a), 'junction of ($b | $c | $a) matches at least one empty string');
34 ok('' eq any($b, $c, $a), 'junction of any($b, $c, $a) matches at least one empty string');
35
36 # make sure that ~only~ one of them matches 'a'
37 ok('a' eq ($b ^ $c ^ $a), 'junction of ($b ^ $c ^ $a) matches at ~only~ one "a"');
38 ok('a' eq one($b, $c, $a), 'junction of one($b, $c, $a) matches at ~only~ one "a"');
39
40 # give $b a value
41 $b = 'a';
42
43 # now this will fail
44 ok('a' ne ($b ^ $c ^ $a), 'junction of ($b ^ $c ^ $a) matches at more than one "a"');
45
46 # change $b and give $c a value
47 $b = 'b';
48 $c = 'c';
49
50 ok('a' eq ($b ^ $c ^ $a), 'junction of ($b ^ $c ^ $a) matches at ~only~ one "a"');
51 ok('b' eq ($a ^ $b ^ $c), 'junction of ($a ^ $b ^ $c) matches at ~only~ one "b"');
52 ok('c' eq ($c ^ $a ^ $b), 'junction of ($c ^ $a ^ $b) matches at ~only~ one "c"');
53
54 ok('a' eq ($b | $c | $a), 'junction of ($b | $c | $a) matches at least one "a"');
55 ok('b' eq ($a | $b | $c), 'junction of ($a | $b | $c) matches at least one "b"');
56 ok('c' eq ($c | $a | $b), 'junction of ($c | $a | $b) matches at least one "c"');
57
58 ok(not(('a' eq ($b | $c | $a)) === Bool::False), 'junctional comparison doesn not mistakenly return both true and false');
59 ok(not(('b' eq ($a | $b | $c)) === Bool::False), 'junctional comparison doesn not mistakenly return both true and false');
60 ok(not(('c' eq ($c | $a | $b)) === Bool::False), 'junctional comparison doesn not mistakenly return both true and false');
61
62 # test junction to junction
63 ok(('a' | 'b' | 'c') eq ($a & $b & $c), 'junction ("a" | "b" | "c") matches junction ($a & $b & $c)');
64 ok(('a' & 'b' & 'c') eq ($a | $b | $c), 'junction ("a" & "b" & "c") matches junction ($a | $b | $c)');
65
66 # mix around variables and literals
67
68 ok(($a & 'b' & 'c') eq ('a' | $b | $c), 'junction ($a & "b" & "c") matches junction ("a" | $b | $c)');
69 ok(($a & 'b' & $c) eq ('a' | $b | 'c'), 'junction ($a & "b" & $c) matches junction ("a" | $b | "c")');
70
71 }
72
73 # same tests, but with junctions as variables
74 {
75 # initalize them all to empty strings
76 my $a = '';
77 my $b = '';
78 my $c = '';
79
80 my $all_of_them = $a & $b & $c;
81 ok('' eq $all_of_them, 'junction variable of ($a & $b & $c) matches and empty string');
82
83 $a = 'a';
84
85 my $any_of_them = $b | $c | $a;
86 ok('a' eq $any_of_them, 'junction variable of ($b | $c | $a) matches at least one "a"');
87 ok('' eq $any_of_them, 'junction variable of ($b | $c | $a) matches at least one empty string');
88
89 my $one_of_them = $b ^ $c ^ $a;
90 ok('a' eq $one_of_them, 'junction variable of ($b ^ $c ^ $a) matches at ~only~ one "a"');
91
92 $b = 'a';
93
94 {
95 my $one_of_them = $b ^ $c ^ $a;
96 ok('a' ne $one_of_them, 'junction variable of ($b ^ $c ^ $a) matches at more than one "a"');
97 }
98
99 $b = 'b';
100 $c = 'c';
101
102 {
103 my $one_of_them = $b ^ $c ^ $a;
104 ok('a' eq $one_of_them, 'junction of ($b ^ $c ^ $a) matches at ~only~ one "a"');
105 ok('b' eq $one_of_them, 'junction of ($a ^ $b ^ $c) matches at ~only~ one "b"');
106 ok('c' eq $one_of_them, 'junction of ($c ^ $a ^ $b) matches at ~only~ one "c"');
107 }
108
109 {
110 my $any_of_them = $b | $c | $a;
111 ok('a' eq $any_of_them, 'junction of ($b | $c | $a) matches at least one "a"');
112 ok('b' eq $any_of_them, 'junction of ($a | $b | $c) matches at least one "b"');
113 ok('c' eq $any_of_them, 'junction of ($c | $a | $b) matches at least one "c"');
114 }
115
116 }
117
118 {
119 my $j = 1 | 2;
120 $j = 5;
121 is($j, 5, 'reassignment of junction variable');
122 }
123
124 {
648ae66 [spec] fudged S03-junctions/misc.t
moritz authored
125 my $j;
126 my $k;
127 my $l;
82ba44c [spec] started to move junction tests (and upate POD). Much more work…
moritz authored
128
129 $j = 1|2;
d511e2d [spec] Explicitly stringify .WHAT result to avoid 'use uninitialised …
bacek authored
130 is(~WHAT($j),'Junction', 'basic junction type reference test');
82ba44c [spec] started to move junction tests (and upate POD). Much more work…
moritz authored
131
132 $k=$j;
d511e2d [spec] Explicitly stringify .WHAT result to avoid 'use uninitialised …
bacek authored
133 is(~WHAT($k),'Junction', 'assignment preserves reference');
82ba44c [spec] started to move junction tests (and upate POD). Much more work…
moritz authored
134
135 # XXX does this next one make any sense?
136 $l=\$j;
8588485 [t/spec] unfudge and s/skip/todo/ some tests for rakudo
moritz authored
137 #?rakudo todo 'prefix:<\\>'
d511e2d [spec] Explicitly stringify .WHAT result to avoid 'use uninitialised …
bacek authored
138 is(~WHAT($l),'Junction', 'hard reference to junction');
82ba44c [spec] started to move junction tests (and upate POD). Much more work…
moritz authored
139 }
140
141
142 =begin description
143
144 Tests junction examples from Synopsis 03
145
146 j() is used to convert a junction to canonical string form, currently
147 just using .perl until a better approach presents itself.
148
149 L<S03/Junctive operators>
150
151 =end description
152
153 # Canonical stringification of a junction
154 sub j (Junction $j) { return $j.perl }
155
156 {
157 # L<S03/Junctive operators/They thread through operations>
648ae66 [spec] fudged S03-junctions/misc.t
moritz authored
158 my $got;
159 my $want;
82ba44c [spec] started to move junction tests (and upate POD). Much more work…
moritz authored
160 $got = ((1|2|3)+4);
161 $want = (5|6|7);
162 is( j($got), j($want), 'thread + returning junctive result');
163
164 $got = ((1|2) + (3&4));
165 $want = ((4|5) & (5|6));
166 is( j($got), j($want), 'thread + returning junctive combination of results');
167
168 # L<S03/Junctive operators/This opens doors for constructions like>
169 # unless $roll == any(1..6) { print "Invalid roll" }
648ae66 [spec] fudged S03-junctions/misc.t
moritz authored
170 my $roll;
171 my $note;
82ba44c [spec] started to move junction tests (and upate POD). Much more work…
moritz authored
172 $roll = 3; $note = '';
173 unless $roll == any(1..6) { $note = "Invalid roll"; };
174 is($note, "", 'any() junction threading ==');
175
176 $roll = 7; $note = '';
177 unless $roll == any(1..6) { $note = "Invalid roll"; };
178 is($note, "Invalid roll", 'any() junction threading ==');
179
180 # if $roll == 1|2|3 { print "Low roll" }
181 $roll = 4; $note = '';
182 if $roll == 1|2|3 { $note = "Low roll" }
183 is($note, "", '| junction threading ==');
184
185 $roll = 2; $note = '';
186 if $roll == 1|2|3 { $note = "Low roll" }
187 is($note, "Low roll", '| junction threading ==');
d0da223 [spec]: Unfudge some junction tests for Rakudo.
pmichaud authored
188 }
82ba44c [spec] started to move junction tests (and upate POD). Much more work…
moritz authored
189
d0da223 [spec]: Unfudge some junction tests for Rakudo.
pmichaud authored
190 #?rakudo skip 'Junctions as subscripts'
191 {
82ba44c [spec] started to move junction tests (and upate POD). Much more work…
moritz authored
192 # L<S03/Junctive operators/Junctions work through subscripting>
648ae66 [spec] fudged S03-junctions/misc.t
moritz authored
193 my $got;
194 my @foo;
82ba44c [spec] started to move junction tests (and upate POD). Much more work…
moritz authored
195 $got = ''; @foo = ();
196 $got ~= 'y' if try { @foo[any(1,2,3)] };
197 is($got, '', "junctions work through subscripting, 0 matches");
198
199 $got = ''; @foo = (0,1);
200 $got ~= 'y' if try { @foo[any(1,2,3)] };
201 is($got, '', "junctions work through subscripting, 1 match");
202
203 $got = ''; @foo = (1,1,1);
204 $got ~= 'y' if try { @foo[any(1,2,3)] };
205 is($got, '', "junctions work through subscripting, 3 matches");
206
207
208 # L<S03/Junctive operators/Junctions are specifically unordered>
209 # Compiler *can* reorder and parallelize but *may not* so don't test
210 # for all(@foo) {...};
211
212 # Not sure what is expected
213 #my %got = ('1' => 1); # Hashes are unordered too
214 #@foo = (2,3,4);
215 #for all(@foo) { %got{$_} = 1; };
216 #is( %got.keys.sort.join(','), '1,2,3,4',
217 # 'for all(...) { ...} as parallelizable');
218 }
219
220 =begin description
221
222 These are implemented but still awaiting clarification on p6l.
223
224 L<S03/Junctive operators/They thread through operations>
225
226 On Fri, 2005-02-11 at 10:46 +1100, Damian Conway wrote:
227 > Subject: Re: Fwd: Junctive puzzles.
228 >
229 > Junctions have an associated boolean predicate that's preserved across
230 > operations on the junction. Junctions also implicitly distribute across
231 > operations, and rejunctify the results.
232
233 =end description
234
648ae66 [spec] fudged S03-junctions/misc.t
moritz authored
235 #?rakudo skip 'Junctions of Code Objects'
82ba44c [spec] started to move junction tests (and upate POD). Much more work…
moritz authored
236 {
237 my @subs = (sub {3}, sub {2});
238
648ae66 [spec] fudged S03-junctions/misc.t
moritz authored
239 my $got;
240 my $want;
82ba44c [spec] started to move junction tests (and upate POD). Much more work…
moritz authored
241
242 is(j(any(@subs)()), j(3|2), '.() on any() junction of subs');
243
244 $want = (3&2);
245 $got = all(@subs)();
246 is(j($got), j($want), '.() on all() junction of subs');
247
248 $want = (3^2);
249 $got = one(@subs)();
250 is(j($got), j($want), '.() on one() junction of subs');
251
252 $want = none(3,2);
253 $got = none(@subs)();
254 is(j($got), j($want), '.() on none() junction of subs');
255
256 $want = one( any(3,2), all(3,2) );
257 $got = one( any(@subs), all(@subs) )();
258 is(j($got), j($want), '.() on complex junction of subs');
259
260 # Avoid future constant folding
261 #my $rand = rand;
262 #my $zero = int($rand-$rand);
263 #my @subs = (sub {3+$zero}, sub {2+$zero});
264 }
265
266 # Check functional and operator versions produce the same structure
267 {
268 is(j((1|2)^(3&4)), j(one(any(1,2),all(3,4))),
269 '((1|2)^(3&4)) equiv to one(any(1,2),all(3,4))');
270
271 is(j((1|2)&(3&4)), j(all(any(1,2),all(3,4))),
272 '((1|2)&(3&4)) equiv to all(any(1,2),all(3,4))');
273
274 is(j((1|2)|(3&4)), j(any(any(1,2),all(3,4))),
275 '((1|2)|(3&4)) equiv to any(any(1,2),all(3,4))');
276 }
277
648ae66 [spec] fudged S03-junctions/misc.t
moritz authored
278 #?rakudo skip 'Junction.pick'
279 {
280 is(none(1).pick, undef, 'none(1).pick should be undef');
281 is(none(1,1).pick, undef, 'none(1,1).pick should be undef');
82ba44c [spec] started to move junction tests (and upate POD). Much more work…
moritz authored
282
648ae66 [spec] fudged S03-junctions/misc.t
moritz authored
283 is(one(1).pick, 1, 'one(1).pick should be 1');
284 is(one(1,1).pick, undef, 'one(1,1).pick should be undef');
82ba44c [spec] started to move junction tests (and upate POD). Much more work…
moritz authored
285
648ae66 [spec] fudged S03-junctions/misc.t
moritz authored
286 is(all(1).pick, 1, 'all(1).pick should be 1');
287 is(all(1,1).pick, 1, 'all(1,1).pick should be 1');
288 is(all(1,2).pick, undef, 'all(1,2).pick should be undef');
289 }
82ba44c [spec] started to move junction tests (and upate POD). Much more work…
moritz authored
290
291 # junction in boolean context
292 ok(?(0&0) == ?(0&&0), 'boolean context');
293 ok(?(0&1) == ?(0&&1), 'boolean context');
294 ok(?(1&1) == ?(1&&1), 'boolean context');
295 ok(?(1&0) == ?(1&&0), 'boolean context');
296 ok(!(?(0&0) != ?(0&&0)), 'boolean context');
297 ok(!(?(0&1) != ?(0&&1)), 'boolean context');
298 ok(!(?(1&1) != ?(1&&1)), 'boolean context');
299 ok(!(?(1&0) != ?(1&&0)), 'boolean context');
300
301
302 {
303 my $c = 0;
304 if 1 == 1 { $c++ }
305 is $c, 1;
306 if 1 == 1|2 { $c++ }
307 is $c, 2;
308 if 1 == 1|2|3 { $c++ }
309 is $c, 3;
310
311 $c++ if 1 == 1;
312 is $c, 4;
313 $c++ if 1 == 1|2;
314 is $c, 5, 'if modifier with junction should be called once';
315
316 $c = 0;
317 $c++ if 1 == 1|2|3;
318 is $c, 1, 'if modifier with junction should be called once';
319
320 $c = 0;
321 $c++ if 1 == any(1, 2, 3);
322 is $c, 1, 'if modifier with junction should be called once';
323 }
57e7ad8 [t] move some junction tests
moritz authored
324
325 {
326 my @array = <1 2 3 4 5 6 7 8>;
327 ok( all(@array) == one(@array), "all(@x) == one(@x) tests uniqueness(+ve)" );
328
329 push @array, 6;
330 ok( !( all(@array) == one(@array) ), "all(@x) == one(@x) tests uniqueness(-ve)" );
331
332 }
Something went wrong with that request. Please try again.