make hyper operators work on nested arrays #1773
Comments
From pkailasa@gmail.comPlease review the patch attached which lets hyper operators be used on >> perl6 -e 'my @r = (1, 2, [3, 4]) >>+<< (4, 5, [6, 7]); say @r.perl' >> perl6 -e 'my @r = (1, 2, [3, 4]); @r>>++; say @r.perl' More tests were added to properly compare the nested arrays (not just Patched files: Thanks, |
From pkailasa@gmail.commetaops.pm.patchdiff --git a/src/core/metaops.pm b/src/core/metaops.pm
index 7dbd1ef..dfc83c3 100644
--- a/src/core/metaops.pm
+++ b/src/core/metaops.pm
@@ -88,7 +88,11 @@ our multi sub hyper(&op, Iterable $lhs-iterable, Iterable $rhs-iterable, :$dwim-
my @result;
for @lhs Z @rhs -> $l, $r {
- @result.push(op($l, $r));
+ if $l ~~ Iterable || $r ~~ Iterable {
+ @result.push([hyper(&op, $l.list, $r.list, :$dwim-left, :$dwim-right)]);
+ } else {
+ @result.push(op($l, $r));
+ }
}
@result
}
@@ -100,7 +104,19 @@ our multi sub hyper(&op, $lhs, $rhs, :$dwim-left, :$dwim-right) {
our multi sub hyper(&op, @arg) {
my @result;
for @arg {
- @result.push(op($_));
+
+ # this should work, but isn't :(
+
+ # if $_ ~~ Iterable {
+ # @result.push([hyper(&op, $_)]);
+ # } else {
+ # @result.push(op($_));
+ # }
+
+ # this is terribly ugly; but works
+
+ @result.push([hyper(&op, $_)]) if $_ ~~ Iterable;
+ @result.push(op($_)) if $_ !~~ Iterable;
}
@result
}
|
From pkailasa@gmail.comhyper.t.patchIndex: t/spec/S03-metaops/hyper.t
===================================================================
--- t/spec/S03-metaops/hyper.t (revision 30688)
+++ t/spec/S03-metaops/hyper.t (working copy)
@@ -76,13 +76,13 @@
{ # unary postfix
my @r = (1, 2, 3);
- try { @r»++ };
+ @r»++;
my @e = (2, 3, 4);
#?pugs todo
is(~@r, ~@e, "hyper auto increment an array");
@r = (1, 2, 3);
- try { @r>>++ };
+ @r>>++;
@e = (2, 3, 4);
#?pugs todo
is(~@r, ~@e, "hyper auto increment an array ASCII notation");
@@ -223,66 +223,76 @@
is(~@r, ~@e, "hyper-method-call on list of user-defined objects");
};
-#?rakudo skip 'unicode'
+#?rakudo todo 'unicode'
{ # distribution for unary prefix
my @r;
@r = -« ([1, 2], [3, [4, 5]]);
my @e = ([-1, -2], [-3, [-4, -5]]);
is(~@r, ~@e, "distribution for unary prefix");
+ is_deeply(@r, @e, "distribution for unary prefix, deep comparison");
@r = -<< ([1, 2], [3, [4, 5]]);
@e = ([-1, -2], [-3, [-4, -5]]);
is(~@r, ~@e, "distribution for unary prefix, ASCII");
+ is_deeply(@r, @e, "distribution for unary prefix, ASCII, deep comparison");
};
-#?rakudo skip 'unicode'
+#?rakudo todo 'unicode'
{ # distribution for unary postfix autoincrement
my @r;
@r = ([1, 2], [3, [4, 5]]);
- try { @r»++ };
+ @r»++;
my @e = ([2, 3], [4, [5, 6]]);
#?pugs todo
is(~@r, ~@e, "distribution for unary postfix autoincr");
+ is_deeply(@r, @e, "distribution for unary postfix autoincr, deep comparison");
@r = ([1, 2], [3, [4, 5]]);
- try { @r>>++ };
+ @r>>++;
@e = ([2, 3], [4, [5, 6]]);
#?pugs todo
is(~@r, ~@e, "distribution for unary postfix autoincr, ASCII");
+ is_deeply(@r, @e, "distribution for unary postfix autoincr, ASCII, deep comparison");
};
#?DOES 3
-#?rakudo skip 'non-unicode hypers'
+#?rakudo todo 'non-unicode hypers'
{ # distribution for binary infix - ASCII
my @r;
@r = (1, 2, [3, 4]) >>+<< (4, 5, [6, 7]);
my @e = (5, 7, [9, 11]);
is(~@r, ~@e, "distribution for binary infix, same shape, ASCII");
+ is_deeply(@r, @e, "distribution for binary infix, same shape, ASCII, deep comparision");
@r = (1, 2, [3, 4]) >>+>> (5, 6, 7);
@e = (6, 8, [10, 11]);
is(~@r, ~@e, "distribution for binary infix, dimension upgrade, ASCII");
+ is_deeply(@r, @e, "distribution for binary infix, dimension upgrade, ASCII, deep comparison");
@r = ([1, 2], 3) <<+>> (4, [5, 6]);
@e = ([5, 6], [8, 9]);
is(~@r, ~@e, "distribution for binary infix, S03 cross-upgrade, ASCII");
+ is_deeply(@r, @e, "distribution for binary infix, S03 cross-upgrade, ASCII, deep comparison");
};
#?DOES 3
-#?rakudo skip 'unicode hypers'
+#?rakudo todo 'unicode hypers'
{ # distribution for binary infix - unicode
my @r;
@r = (1, 2, [3, 4]) »+« (4, 5, [6, 7]);
my @e = (5, 7, [9, 11]);
is(~@r, ~@e, "distribution for binary infix, same shape");
+ is_deeply(@r, @e, "distribution for binary infix, same shape, deep comparison");
- @r = (1, 2, [3, 4]) »+« (5, 6, 7);
+ @r = (1, 2, [3, 4]) »+» (5, 6, 7);
@e = (6, 8, [10, 11]);
is(~@r, ~@e, "distribution for binary infix, dimension upgrade");
+ is_deeply(@r, @e, "distribution for binary infix, dimension upgrade, deep comparison");
- @r = ([1, 2], 3) »+« (4, [5, 6]);
+ @r = ([1, 2], 3) «+» (4, [5, 6]);
@e = ([5, 6], [8, 9]);
is(~@r, ~@e, "distribution for binary infix, S03 cross-upgrade");
+ is_deeply(@r, @e, "distribution for binary infix, S03 cross-upgrade, deep comparison");
};
{ # regression test, ensure that hyper works on arrays
@@ -338,7 +348,7 @@
ok ?(@a »|« @b), '»|« hyperjunction evals';
ok ?(@a >>|<< @b), '>>|<< hyperjunction evals, ASCII';
ok ?(@a »&« @b), '»&« hyperjunction evals';
- ok ?(@a >>&<< @b), '»&« hyperjunction evals, ASCII';
+ ok ?(@a >>&<< @b), '>>&<< hyperjunction evals, ASCII';
}
# test hypers on hashes
|
From pk-rakudo@kailasa.netOn Fri May 21 10:41:39 2010, pkailasa@gmail.com wrote:
The form '$l ~~ Iterable' in the patch now causes compilation error. It Revised patch file is attached. |
From pk-rakudo@kailasa.netmetaops.pm.patchdiff --git a/src/core/metaops.pm b/src/core/metaops.pm
index 7dbd1ef..b0ea763 100644
--- a/src/core/metaops.pm
+++ b/src/core/metaops.pm
@@ -88,7 +88,11 @@ our multi sub hyper(&op, Iterable $lhs-iterable, Iterable $rhs-iterable, :$dwim-
my @result;
for @lhs Z @rhs -> $l, $r {
- @result.push(op($l, $r));
+ if Iterable.ACCEPTS($l) || Iterable.ACCEPTS($r) {
+ @result.push([ hyper(&op, $l.list, $r.list, :$dwim-left, :$dwim-right) ]);
+ } else {
+ @result.push(op($l, $r));
+ }
}
@result
}
@@ -100,7 +104,19 @@ our multi sub hyper(&op, $lhs, $rhs, :$dwim-left, :$dwim-right) {
our multi sub hyper(&op, @arg) {
my @result;
for @arg {
- @result.push(op($_));
+
+ # this should work, but isn't :(
+
+ # if $_ ~~ Iterable {
+ # @result.push([hyper(&op, $_)]);
+ # } else {
+ # @result.push(op($_));
+ # }
+
+ # this is terribly ugly; but works
+
+ @result.push([hyper(&op, $_)]) if Iterable.ACCEPTS($_);
+ @result.push(op($_)) if Iterable.REJECTS($_);
}
@result
}
|
|
The RT System itself - Status changed from 'new' to 'open' |
From @cokeOn Fri May 21 10:41:39 2010, pkailasa@gmail.com wrote:
Prakash - Sorry it's taken us so long to get to this patch, but it no longer applies cleanly[1]; but on the Thanks! [1] Might even have been your patch that did it, and this ticket was just never closed. |
|
@coke - Status changed from 'open' to 'resolved' |
Migrated from rt.perl.org#75246 (status was 'resolved')
Searchable as RT75246$
The text was updated successfully, but these errors were encountered: