Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

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