t/spec/S03-metaops/hyper.t

   1 use v6;
   2
   3 use Test;
   4
   5 =begin pod
   6
   7  Hyper operators L<S03/"Hyper operators">
   8
   9 =end pod
  10
  11 plan *;
  12
  13 # L<S03/Hyper operators>
  14  # binary infix
  15 my @r;
  16 my @e;
  17 {
  18         @r = (1, 2, 3) »+« (2, 4, 6);
  19         @e = (3, 6, 9);
  20         is(~@r, ~@e, "hyper-sum two arrays");
  21
  22         @r = (1, 2, 3) »-« (2, 4, 6);
  23         @e = (-1, -2, -3);
  24         is(~@r, ~@e, "hyper-subtract two arrays");
  25
  26         @r = (1, 2, 3) »*« (2, 4, 6);
  27         @e = (2, 8, 18);
  28         is(~@r, ~@e, "hyper-multiply two arrays");
  29
  30         @r = (1, 2, 3) »x« (3, 2, 1);
  31         @e = ('111', '22', '3');
  32         is(~@r, ~@e, "hyper-x two arrays");
  33
  34         @r = (1, 2, 3) »xx« (3, 2, 1);
  35         @e = ((1,1,1), (2,2), (3));
  36         is(~@r, ~@e, "hyper-xx two arrays");
  37
  38         @r = (20, 40, 60) »div« (2, 5, 10);
  39         @e = (10, 8, 6);
  40         is(~@r, ~@e, "hyper-divide two arrays");
  41
  42         @r = (1, 2, 3) »+« (10, 20, 30) »*« (2, 3, 4);
  43         @e = (21, 62, 123);
  44         is(~@r, ~@e, "precedence - »+« vs »*«");
  45 }
  46
  47 {
  48         @r = (1, 2, 3) >>+<< (2, 4, 6);
  49         @e = (3, 6, 9);
  50         is(~@r, ~@e, "hyper-sum two arrays ASCII notation");
  51
  52         @r = (1, 2, 3) >>-<< (2, 4, 6);
  53         @e = (-1, -2, -3);
  54         is(~@r, ~@e, "hyper-subtract two arrays ASCII notation");
  55
  56         @r = (1, 2, 3) >>*<< (2, 4, 6);
  57         @e = (2, 8, 18);
  58         is(~@r, ~@e, "hyper-multiply two arrays ASCII notation");
  59
  60         @r = (1, 2, 3) >>x<< (3, 2, 1);
  61         @e = ('111', '22', '3');
  62         is(~@r, ~@e, "hyper-x two arrays ASCII notation");
  63
  64         @r = (1, 2, 3) >>xx<< (3, 2, 1);
  65         @e = ((1,1,1), (2,2), (3));
  66         is(~@r, ~@e, "hyper-xx two arrays ASCII notation");
  67
  68         @r = (20, 40, 60) >>div<< (2, 5, 10);
  69         @e = (10, 8, 6);
  70         is(~@r, ~@e, "hyper-divide two arrays ASCII notation");
  71
  72         @r = (1, 2, 3) >>+<< (10, 20, 30) >>*<< (2, 3, 4);
  73         @e = (21, 62, 123);
  74         is(~@r, ~@e, "precedence - >>+<< vs >>*<< ASCII notation");
  75 };
  76
  77 { # unary postfix
  78         my @r = (1, 2, 3);
  79         @r»++;
  80         my @e = (2, 3, 4);
  81         #?pugs todo
  82         is(~@r, ~@e, "hyper auto increment an array");
  83
  84         @r = (1, 2, 3);
  85         @r>>++;
  86         @e = (2, 3, 4);
  87         #?pugs todo
  88         is(~@r, ~@e, "hyper auto increment an array ASCII notation");
  89 };
  90
  91 { # unary prefix
  92         my @r;
  93         @r = -« (3, 2, 1);
  94         my @e = (-3, -2, -1);
  95         is(~@r, ~@e, "hyper op on assignment/pipeline");
  96
  97         @r = -<< (3, 2, 1);
  98         @e = (-3, -2, -1);
  99         is(~@r, ~@e, "hyper op on assignment/pipeline ASCII notation");
 100 };
 101
 102 { # dimension upgrade - ASCII
 103         my @r;
 104         @r = (1, 2, 3) >>+>> 1;
 105         my @e = (2, 3, 4);
 106         is(~@r, ~@e, "auto dimension upgrade on rhs ASCII notation");
 107
 108         @r = 2 <<*<< (10, 20, 30);
 109         @e = (20, 40, 60);
 110         is(~@r, ~@e, "auto dimension upgrade on lhs ASCII notation");
 111 }
 112
 113 #?rakudo todo 'list level extension'
 114 { # list level extension
 115         @r = (1,2,3,4) >>+>> (1,2);
 116         @e = (2,4,3,4);
 117         is(~@r, ~@e, "list-level element extension on rhs ASCII notation");
 118
 119         @r = (1,2) <<+<< (1,2,3,4);
 120         @e = (2,4,3,4);
 121         is(~@r, ~@e, "list-level element extension on lhs ASCII notation");
 122
 123         @r = (1,2,3,4) >>+>> (1,);
 124         @e = (2,2,3,4);
 125         is(~@r, ~@e, "list-level element extension on rhs ASCII notation");
 126
 127         @r = (1,) <<+<< (1,2,3,4);
 128         @e = (2,2,3,4);
 129         is(~@r, ~@e, "list-level element extension on lhs ASCII notation");
 130 };
 131
 132 #?rakudo skip 'unicode hypers'
 133 { # dimension upgrade - unicode
 134         my @r;
 135         @r = (1, 2, 3) »+» 1;
 136         my @e = (2, 3, 4);
 137         is(~@r, ~@e, "auto dimension upgrade on rhs");
 138
 139         @r = 2 «*« (10, 20, 30);
 140         @e = (20, 40, 60);
 141         is(~@r, ~@e, "auto dimension upgrade on lhs");
 142
 143         @r = (1,2,3,4) »+» (1,2);
 144         @e = (2,4,3,4);
 145         is(~@r, ~@e, "list-level element extension on rhs");
 146
 147         @r = (1,2) «+« (1,2,3,4);
 148         @e = (2,4,3,4);
 149         is(~@r, ~@e, "list-level element extension on lhs");
 150
 151         @r = (1,2,3,4) »+» (1,);
 152         @e = (2,2,3,4);
 153         is(~@r, ~@e, "list-level element extension on rhs");
 154
 155         @r = (1,) «+« (1,2,3,4);
 156         @e = (2,2,3,4);
 157         is(~@r, ~@e, "list-level element extension on lhs");
 158 };
 159
 160 { # unary postfix with integers
 161         my @r;
 162         @r = (1, 4, 9)».sqrt;
 163         my @e = (1, 2, 3);
 164         is(~@r, ~@e, "method call on integer list elements");
 165
 166         @r = (1, 4, 9)>>.sqrt;
 167         @e = (1, 2, 3);
 168         is(~@r, ~@e, "method call on integer list elements (ASCII)");
 169 }
 170
 171 #?rakudo skip '@array»++'
 172 {
 173
 174         my (@r, @e);
 175         (@r = (1, 4, 9))»++;
 176         @e = (2, 5, 10);
 177         is(~@r, ~@e, "operator call on integer list elements");
 178
 179         (@r = (1, 4, 9)).»++;
 180         is(~@r, ~@e, "operator call on integer list elements (Same thing, dot form)");
 181
 182         (@r = (1, 4, 9))».++;
 183         @e = (2, 5, 9);
 184         is(~@r, ~@e, "operator call on integer list elements (Same thing, dot form)");
 185
 186         (@r = (1, 4, 9)).».++;
 187         is(~@r, ~@e, "operator call on integer list elements (Same thing, dot form)");
 188
 189         (@r = (1, 4, 9))\  .»\  .++;
 190         @e = (2, 5, 9);
 191         is(~@r, ~@e, "operator call on integer list elements (Same thing, upspace form)");
 192 };
 193
 194 { # unary postfix again, but with a twist
 195         my @r;
 196         eval '@r = ("f", "oo", "bar")».chars';
 197         my @e = (1, 2, 3);
 198         is(~@r, ~@e, "method call on list elements");
 199
 200         eval '@r = ("f", "oo", "bar").».chars';
 201         @e = (1, 2, 3);
 202         is(~@r, ~@e, "method call on list elements (Same thing, dot form)");
 203
 204
 205         eval '@r = ("f", "oo", "bar")>>.chars';
 206         @e = (1, 2, 3);
 207         is(~@r, ~@e, "method call on list elements (ASCII)");
 208
 209         eval '@r = ("f", "oo", "bar").>>.chars';
 210         @e = (1, 2, 3);
 211         is(~@r, ~@e, "method call on list elements (ASCII, Same thing, dot form)");
 212
 213 };
 214
 215 { # unary postfix on a user-defined object
 216         my $t;
 217         class FooTest { method bar { 42 } }; $t = FooTest.new.bar;
 218         is($t, 42, 'plain method call works OK');
 219
 220         my @r;
 221         class FooTest2 { method bar { 42 } }; @r = (FooTest2.new)>>.bar;
 222         my @e = (42);
 223         is(~@r, ~@e, "hyper-method-call on list of user-defined objects");
 224 };
 225
 226 { # distribution for unary prefix
 227         my @r;
 228         @r = -« ([1, 2], [3, [4, 5]]);
 229         my @e = ([-1, -2], [-3, [-4, -5]]);
 230         is(~@r, ~@e, "distribution for unary prefix");
 231         is_deeply(@r, @e, "distribution for unary prefix, deep comparison");
 232
 233         @r = -<< ([1, 2], [3, [4, 5]]);
 234         @e = ([-1, -2], [-3, [-4, -5]]);
 235         is(~@r, ~@e, "distribution for unary prefix, ASCII");
 236         is_deeply(@r, @e, "distribution for unary prefix, ASCII, deep comparison");
 237 };
 238
 239 { # distribution for unary postfix autoincrement
 240         my @r;
 241         @r = ([1, 2], [3, [4, 5]]);
 242         @r»++;
 243         my @e = ([2, 3], [4, [5, 6]]);
 244         #?pugs todo
 245         is(~@r, ~@e, "distribution for unary postfix autoincr");
 246         is_deeply(@r, @e, "distribution for unary postfix autoincr, deep comparison");
 247
 248         @r = ([1, 2], [3, [4, 5]]);
 249         @r>>++;
 250         @e = ([2, 3], [4, [5, 6]]);
 251         #?pugs todo
 252         is(~@r, ~@e, "distribution for unary postfix autoincr, ASCII");
 253         is_deeply(@r, @e, "distribution for unary postfix autoincr, ASCII, deep comparison");
 254 };
 255
 256 #?DOES 3
 257 { # distribution for binary infix - ASCII
 258         my @r;
 259         @r = (1, 2, [3, 4]) >>+<< (4, 5, [6, 7]);
 260         my @e = (5, 7, [9, 11]);
 261         is(~@r, ~@e, "distribution for binary infix, same shape, ASCII");
 262         is_deeply(@r, @e, "distribution for binary infix, same shape, ASCII, deep comparision");
 263
 264         @r = (1, 2, [3, 4]) >>+>> (5, 6, 7);
 265         @e = (6, 8, [10, 11]);
 266         is(~@r, ~@e, "distribution for binary infix, dimension upgrade, ASCII");
 267         is_deeply(@r, @e, "distribution for binary infix, dimension upgrade, ASCII, deep comparison");
 268
 269         @r = ([1, 2], 3) <<+>> (4, [5, 6]);
 270         @e = ([5, 6], [8, 9]);
 271         is(~@r, ~@e, "distribution for binary infix, S03 cross-upgrade, ASCII");
 272         is_deeply(@r, @e, "distribution for binary infix, S03 cross-upgrade, ASCII, deep comparison");
 273 };
 274
 275 #?DOES 3
 276 { # distribution for binary infix - unicode
 277         my @r;
 278         @r = (1, 2, [3, 4]) »+« (4, 5, [6, 7]);
 279         my @e = (5, 7, [9, 11]);
 280         is(~@r, ~@e, "distribution for binary infix, same shape");
 281         is_deeply(@r, @e, "distribution for binary infix, same shape, deep comparison");
 282
 283         @r = (1, 2, [3, 4]) »+» (5, 6, 7);
 284         @e = (6, 8, [10, 11]);
 285         is(~@r, ~@e, "distribution for binary infix, dimension upgrade");
 286         is_deeply(@r, @e, "distribution for binary infix, dimension upgrade, deep comparison");
 287
 288         @r = ([1, 2], 3) «+» (4, [5, 6]);
 289         @e = ([5, 6], [8, 9]);
 290         is(~@r, ~@e, "distribution for binary infix, S03 cross-upgrade");
 291         is_deeply(@r, @e, "distribution for binary infix, S03 cross-upgrade, deep comparison");
 292 };
 293
 294 { # regression test, ensure that hyper works on arrays
 295         my @r1;
 296         my @r2;
 297         my @e1 = (2, 4, 6);
 298         my @a = (1, 2, 3);
 299         @r1 = @a >>+<< @a;
 300         is(~@r1, ~@e1, "hyper op works on variables, too.");
 301 }
 302 {
 303         my @a = (1, 2, 3);
 304         my @e2 = (2, 3, 4);
 305         my @r2 = @a >>+>> 1;
 306         is(~@r2, ~@e2, "hyper op and correctly promotes scalars");
 307 };
 308
 309
 310 # mixed hyper and reduce metaops -
 311 # this unveils a spec bug as << recurses into arrays and [+] never gets applied,
 312 # so we disable the entire chunk for now.
 313 =begin todo unspecced
 314
 315     is ~([+]<< ([1,2,3], [4,5,6])), "6 15", "mixed hyper and reduce metaop ([+]<<) works";
 316     ## XXX: Test for [+]<<<< - This is unspecced, commenting it out
 317     #is ~([+]<<<< ([[1,2],[3,4]],[[5,6],[7,8]])), "3 7 11 15",
 318     #  "mixed double hyper and reduce metaop ([+]<<<<) works";
 319
 320     is ~([+]« [1,2,3], [4,5,6]), "6 15",
 321       "mixed Unicode hyper and reduce metaop ([+]«) works";
 322
 323 =end todo unspecced
 324
 325 #?pugs todo 'hyper ops'
 326 { # hyper dereferencing
 327     my @array = (
 328         { key => 'val' },
 329         { key => 'val' },
 330         { key => 'val' }
 331     );
 332
 333     my $full = join '', eval '@array>>.<key>';
 334     is($full, 'valvalval', 'hyper-dereference an array');
 335
 336     my $part = join '', eval '@array[0,1]>>.<key>';
 337     is($part, 'valval', 'hyper-dereference an array slice');
 338 }
 339
 340 #?pugs todo 'feature'
 341 { # junction hyper -- regression?
 342     my @a = 1..3;
 343     my @b = 4..6;
 344     ok ?(@a »|« @b), '»|« hyperjunction evals';
 345     ok ?(@a >>|<< @b), '>>|<< hyperjunction evals, ASCII';
 346     ok ?(@a »&« @b), '»&« hyperjunction evals';
 347     ok ?(@a >>&<< @b), '>>&<< hyperjunction evals, ASCII';
 348 }
 349
 350 # test hypers on hashes
 351 {
 352     my %a = a => 1, b => 2, c => 3;
 353     my %b = a => 5, b => 6, c => 7;
 354     my %c = a => 1, b => 2;
 355     my %d = a => 5, b => 6;
 356
 357     my %r;
 358     %r = %a >>+<< %b;
 359     is +%r,   3,  'hash - >>+<< result has right number of keys (same keys)';
 360     is %r<a>, 6,  'hash - correct result form >>+<< (same keys)';
 361     is %r<b>, 8,  'hash - correct result form >>+<< (same keys)';
 362     is %r<c>, 10, 'hash - correct result form >>+<< (same keys)';
 363
 364     %r = %a »+« %d;
 365     is +%r,   3, 'hash - »+« result has right number of keys (union test)';
 366     is %r<a>, 6, 'hash - correct result form »+« (union test)';
 367     is %r<b>, 8, 'hash - correct result form »+« (union test)';
 368     is %r<c>, 3, 'hash - correct result form »+« (union test)';
 369
 370     %r = %c >>+<< %b;
 371     is +%r,   3, 'hash - >>+<< result has right number of keys (union test)';
 372     is %r<a>, 6, 'hash - correct result form >>+<< (union test)';
 373     is %r<b>, 8, 'hash - correct result form >>+<< (union test)';
 374     is %r<c>, 7, 'hash - correct result form >>+<< (union test)';
 375
 376     %r = %a <<+>> %b;
 377     is +%r,   3,  'hash - <<+>> result has right number of keys (same keys)';
 378     is %r<a>, 6,  'hash - correct result form <<+>> (same keys)';
 379     is %r<b>, 8,  'hash - correct result form <<+>> (same keys)';
 380     is %r<c>, 10, 'hash - correct result form <<+>> (same keys)';
 381
 382     %r = %a <<+>> %d;
 383     is +%r,   2, 'hash - <<+>> result has right number of keys (intersection test)';
 384     is %r<a>, 6, 'hash - correct result form <<+>> (intersection test)';
 385     is %r<b>, 8, 'hash - correct result form <<+>> (intersection test)';
 386
 387     %r = %c <<+>> %b;
 388     is +%r,   2, 'hash - <<+>> result has right number of keys (intersection test)';
 389     is %r<a>, 6, 'hash - correct result form <<+>> (intersection test)';
 390     is %r<b>, 8, 'hash - correct result form <<+>> (intersection test)';
 391
 392     %r = %a >>+>> %c;
 393     is +%r,   3, 'hash - >>+>> result has right number of keys';
 394     is %r<a>, 2, 'hash - correct result from >>+>>';
 395     is %r<b>, 4, 'hash - correct result from >>+>>';
 396     is %r<c>, 3, 'hash - correct result from >>+>>';
 397
 398     %r = %c >>+>> %b;
 399     is +%r,   2, 'hash - >>+>> result has right number of keys';
 400     is %r<a>, 6, 'hash - correct result from >>+>>';
 401     is %r<b>, 8, 'hash - correct result from >>+>>';
 402
 403     %r = %c <<+<< %a;
 404     is +%r,   3, 'hash - <<+<< result has right number of keys';
 405     is %r<a>, 2, 'hash - correct result from <<+<<';
 406     is %r<b>, 4, 'hash - correct result from <<+<<';
 407     is %r<c>, 3, 'hash - correct result from <<+<<';
 408
 409     %r = %b <<+<< %c;
 410     is +%r,   2, 'hash - <<+<< result has right number of keys';
 411     is %r<a>, 6, 'hash - correct result from <<+<<';
 412     is %r<b>, 8, 'hash - correct result from <<+<<';
 413 }
 414
 415 {
 416     my %a = a => 1, b => 2, c => 3;
 417     my %r = -<<%a;
 418     is +%r,   3, 'hash - -<< result has right number of keys';
 419     is %r<a>, -1, 'hash - correct result from -<<';
 420     is %r<b>, -2, 'hash - correct result from -<<';
 421     is %r<c>, -3, 'hash - correct result from -<<';
 422
 423     %r = --<<%a;
 424     is +%r,   3, 'hash - --<< result has right number of keys';
 425     is %r<a>, 0, 'hash - correct result from --<<';
 426     is %r<b>, 1, 'hash - correct result from --<<';
 427     is %r<c>, 2, 'hash - correct result from --<<';
 428     is +%a,   3, 'hash - --<< result has right number of keys';
 429     is %a<a>, 0, 'hash - correct result from --<<';
 430     is %a<b>, 1, 'hash - correct result from --<<';
 431     is %a<c>, 2, 'hash - correct result from --<<';
 432
 433     %r = %a>>++;
 434     is +%r,   3, 'hash - >>++ result has right number of keys';
 435     is %r<a>, 0, 'hash - correct result from >>++';
 436     is %r<b>, 1, 'hash - correct result from >>++';
 437     is %r<c>, 2, 'hash - correct result from >>++';
 438     is +%a,   3, 'hash - >>++ result has right number of keys';
 439     is %a<a>, 1, 'hash - correct result from >>++';
 440     is %a<b>, 2, 'hash - correct result from >>++';
 441     is %a<c>, 3, 'hash - correct result from >>++';
 442 }
 443
 444 {
 445     our sub postfix:<!>($a) {
 446         [*] 1..$a;
 447     }
 448
 449     my %a = a => 1, b => 2, c => 3;
 450     my %r = %a>>!;
 451     is +%r,   3, 'hash - >>! result has right number of keys';
 452     is %r<a>, 1, 'hash - correct result from >>!';
 453     is %r<b>, 2, 'hash - correct result from >>!';
 454     is %r<c>, 6, 'hash - correct result from >>!';
 455 }
 456
 457
 458 # test non-UTF-8 input
 459 #?pugs skip 'eval(Buf)'
 460 #?rakudo skip 'eval(Buf)'
 461 #?DOES 1
 462 {
 463     my $t = '(1, 2, 3) »+« (4, 3, 2)';
 464     ok !eval($t.encode('ISO-8859-1')),
 465        'Latin-1 »+« without pre-declaration is an error';
 466 }
 467
 468 done_testing;
 469
 470 # vim: ft=perl6