Skip to content
This repository
Browse code

Initial prototype (Perl6) implementation of hyperops

  • Loading branch information...
commit 93cb7dff20ea0ae87066f3b52c75592cff820932 1 parent 0163f97
Stefan O'Rear authored

Showing 2 changed files with 112 additions and 0 deletions. Show diff stats Hide diff stats

  1. +111 0 lib/CORE.setting
  2. +1 0  lib/Test.pm6
111 lib/CORE.setting
@@ -1296,6 +1296,117 @@ sub infix:<..^> ($a, $b) { Range.new($a, $b, :excludes_max) }
1296 1296 sub infix:<^..> ($a, $b) { Range.new($a, $b, :excludes_min) }
1297 1297 sub infix:<^..^> ($a, $b) { Range.new($a, $b, :excludes_min, :excludes_max) }
1298 1298
  1299 +sub _hyper_type($val) {
  1300 + #FIXME rewrite using roles
  1301 + given $val {
  1302 + when Hash { return 1 }
  1303 + when List { return 2 }
  1304 + when Parcel { return 2 }
  1305 + when Range { return 2 }
  1306 + default { return 0 }
  1307 + }
  1308 +}
  1309 +
  1310 +sub hyperunary(&fun, \$obj) {
  1311 + given _hyper_type($obj) {
  1312 + when 1 {
  1313 + my %out;
  1314 + for $obj.kv -> $k, \$v {
  1315 + %out{$k} = hyperunary(&fun, $v);
  1316 + }
  1317 + return %out;
  1318 + }
  1319 + when 2 {
  1320 + my @out;
  1321 + @out.push: $( hyperunary(&fun, $_) ) for $obj.list;
  1322 + return @out;
  1323 + }
  1324 + when 3 {
  1325 + my @out;
  1326 + @out.push: $( hyperunary(&fun, $_) ) for $obj.list;
  1327 + return $obj.new(@out);
  1328 + }
  1329 + when 0 {
  1330 + return fun($obj);
  1331 + }
  1332 + }
  1333 +}
  1334 +
  1335 +sub _hyper_hash($dwiml, $dwimr, $fun, $left, $right) {
  1336 + my %keys;
  1337 + for $left.keys {
  1338 + %keys{$_} = True if !$dwiml || ($right{$_}:exists);
  1339 + }
  1340 + for $right.keys {
  1341 + %keys{$_} = True if !$dwimr || ($left{$_}:exists);
  1342 + }
  1343 + for %keys.keys {
  1344 + %keys{$_} = hyper($dwiml, $dwimr, $fun, $left{$_}, $right{$_});
  1345 + }
  1346 + %keys
  1347 +}
  1348 +
  1349 +sub _hyper_posi($dwiml, $dwimr, $fun, $left, $right) {
  1350 + my $lex = $left[*-1] ~~ Whatever;
  1351 + my $rex = $right[*-1] ~~ Whatever;
  1352 + my @out;
  1353 + my $ix = 0;
  1354 + loop {
  1355 + my $lend; my $lv; my $rend; my $rv;
  1356 + if $ix >= ($lex ?? $left - 1 !! $left) {
  1357 + $lend = True;
  1358 + $lv := $left[$lex ?? $left - 2 !! $left ?? $ix % $left !! 0];
  1359 + } else {
  1360 + $lv := $left[$ix];
  1361 + }
  1362 + if $ix >= ($rex ?? $right - 1 !! $right) {
  1363 + $rend = True;
  1364 + $rv := $right[$rex ?? $right - 2 !! $right ?? $ix % $right !! 0];
  1365 + } else {
  1366 + $rv := $right[$ix];
  1367 + }
  1368 + last if $lend && $rend;
  1369 + die "Ran off end of non-dwimmy left" if $lend && !$dwiml && !$dwimr;
  1370 + die "Ran off end of non-dwimmy right" if $rend && !$dwiml && !$dwimr;
  1371 + last if $lend && !$dwiml;
  1372 + last if $rend && !$dwimr;
  1373 + @out.push: $( hyper($dwiml, $dwimr, $fun, $lv, $rv) );
  1374 + $ix++;
  1375 + }
  1376 + @out;
  1377 +}
  1378 +
  1379 +sub hyper($dwiml, $dwimr, $fun, \$left, \$right) {
  1380 + constant @htnames = 'scalar', 'Associative', 'Positional', #OK
  1381 + 'non-Positional Iterable';
  1382 + my $h1 = _hyper_type($left);
  1383 + my $h2 = _hyper_type($right);
  1384 +
  1385 + if $h1 && $h2 && $h1 != $h2 {
  1386 + die "Cannot mix @htnames[$h1] and @htnames[$h2] in hyperop";
  1387 + }
  1388 +
  1389 + if $h2 == 0 || $h1 == 0 {
  1390 + if $h1 == 0 && $h2 == 0 { return $fun($left, $right) }
  1391 + if $h2 {
  1392 + if $dwiml {
  1393 + return hyperunary(sub (\$x) { $fun($left,$x) }, $right);
  1394 + }
  1395 + } else {
  1396 + if $dwimr {
  1397 + return hyperunary(sub (\$x) { $fun($x,$right) }, $left);
  1398 + }
  1399 + }
  1400 + die "Non-dwimmy scalar used with complex item";
  1401 + }
  1402 +
  1403 + given $h1 {
  1404 + when 1 { return _hyper_hash($dwiml, $dwimr, $fun, $left, $right) }
  1405 + when 2 { return _hyper_posi($dwiml, $dwimr, $fun, @$left, @$right) }
  1406 + when 3 { die "Cannot hyper two unordered collections" }
  1407 + }
  1408 +}
  1409 +
1299 1410 sub infix:<%%> ($x,$y) { $x % $y == 0 }
1300 1411 sub infix:<?&> ($a, $b) { ?($a && $b) }
1301 1412 sub infix:<?|> ($a, $b) { ?($a || $b) }
1  lib/Test.pm6
@@ -79,6 +79,7 @@ sub nok(\$bool, $tag?) is export { $*TEST-BUILDER.ok(!$bool, $tag) }
79 79 sub pass($tag?) is export { $*TEST-BUILDER.ok(1, $tag) }
80 80 sub flunk($tag?) is export { $*TEST-BUILDER.ok(0, $tag) }
81 81 sub isa_ok($obj, $type, $tag?) is export { $*TEST-BUILDER.ok($obj.^isa($type), $tag) }
  82 +sub is_deeply($a,$b,$c) is export { is $a.perl, $b.perl, $c }
82 83 sub is($got, $expected, $tag?) is export {
83 84
84 85 # avoid comparing twice

0 comments on commit 93cb7df

Please sign in to comment.
Something went wrong with that request. Please try again.