Implement fatarrows

Niecza/Actions.pm

@@ -597,11 +597,9 @@ sub INFIX { my ($cl, $M) = @_;
     } elsif ($s eq '&infix:<,>') {
         #XXX STD bug causes , in setting to be parsed as left assoc
         my @r;
-        push @r, $l->splittable_parcel ? @{ $l->positionals } : ($l);
-        push @r, $r->splittable_parcel ? @{ $r->positionals } : ($r);
-        $M->{_ast} = Op::CallSub->new(node($M),
-            invocant => Op::Lexical->new(name => '&infix:<,>'),
-            positionals => \@r);
+        push @r, $l->isa('Op::SimpleParcel') ? @{ $l->items } : ($l);
+        push @r, $r->isa('Op::SimpleParcel') ? @{ $r->items } : ($r);
+        $M->{_ast} = Op::SimpleParcel->new(items => \@r);
     } else {
         $M->{_ast} = Op::CallSub->new(node($M),
             invocant => Op::Lexical->new(node($M), name => $s),
@@ -655,7 +653,9 @@ sub LIST { my ($cl, $M) = @_;
     my ($st, @pos) = $cl->whatever_precheck("&infix:<$op>",
         grep { defined } map { $_->{_ast} } @{ $M->{list} });
 
-    if ($loose2tight{$op}) {
+    if ($op eq ',') {
+        $M->{_ast} = Op::SimpleParcel->new(node($M), items => \@pos);
+    } elsif ($loose2tight{$op}) {
         $M->{_ast} = Op::ShortCircuit->new(node($M), kind => $loose2tight{$op},
             args => \@pos);
     } else {
@@ -743,8 +743,8 @@ sub semilist_to_args { my ($cl, $M) = @_;
 
     if (!defined $al) {
         return [];
-    } elsif ($al && $al->splittable_parcel) {
-        return $al->positionals;
+    } elsif ($al && $al->isa('Op::SimpleParcel')) {
+        return $al->items;
     } else {
         return [$al];
     }
@@ -837,9 +837,14 @@ sub colonpair { my ($cl, $M) = @_;
     my $tk = Op::StringLiteral->new(text => $M->{k});
     my $tv = ref($M->{v}) ? $M->{v}{_ast} :
         Op::Lexical->new(name => $M->{v} ? 'True' : 'False');
-    $M->{_ast} = { ext => $n, term => Op::CallSub->new(
-        invocant => Op::Lexical->new(name => '&_pair'),
-        positionals => [ $tk, $tv ]) };
+    $M->{_ast} = { ext => $n, term => Op::SimplePair->new(
+            key => $tk, value => $tv) };
+}
+
+sub fatarrow { my ($cl, $M) = @_;
+    $M->{_ast} = Op::SimplePair->new(
+        key => Op::StringLiteral->new(text => $M->{key}->Str),
+        value => $M->{val}{_ast});
 }
 
 my %_nowhatever = (map { $_, 1 } ('&infix:<,>', '&infix:<..>', '&infix:<...>',
@@ -994,6 +999,10 @@ sub term__S_colonpair { my ($cl, $M) = @_;
     $M->{_ast} = $M->{colonpair}[0]{_ast}{term};
 }
 
+sub term__S_fatarrow { my ($cl, $M) = @_;
+    $M->{_ast} = $M->{fatarrow}{_ast};
+}
+
 sub do_variable_reference { my ($cl, $M, $v) = @_;
     my $sl = $v->{sigil} . $v->{twigil} . $v->{name};
 
@@ -1453,8 +1462,8 @@ sub arglist { my ($cl, $M) = @_;
 
     if (!defined $x) {
         $M->{_ast} = [];
-    } elsif ($x && $x->splittable_parcel) {
-        $M->{_ast} = $x->positionals;
+    } elsif ($x && $x->isa('Op::SimpleParcel')) {
+        $M->{_ast} = $x->items;
     } else {
         $M->{_ast} = [$x];
     }

Op.pm

@@ -19,18 +19,6 @@ use CgOp;
         map { $_->lift_decls } $self->zyg;
     }
 
-    sub splittable_parcel {
-        my ($self) = @_;
-        $self->isa('Op::CallSub') && $self->invocant->isa('Op::Lexical') &&
-            $self->invocant->name eq '&infix:<,>';
-    }
-
-    sub splittable_pair {
-        my ($self) = @_;
-        $self->isa('Op::CallSub') && $self->invocant->isa('Op::Lexical') &&
-            $self->invocant->name eq '&_pair';
-    }
-
     sub cgop {
         my ($self, $body) = @_;
         if (defined $self->file) {
@@ -203,6 +191,43 @@ use CgOp;
     no Moose;
 }
 
+{
+    package Op::SimplePair;
+    use Moose;
+    extends 'Op';
+
+    has key   => (isa => 'Op', is => 'ro', required => 1);
+    has value => (isa => 'Op', is => 'ro', required => 1);
+    sub zyg { $_[0]->key, $_[0]->value }
+
+    sub code {
+        my ($self, $body) = @_;
+        CgOp::subcall(CgOp::fetch(CgOp::scopedlex('&infix:<=>>')),
+            $self->key->cgop($body), $self->value->cgop($body));
+    }
+
+    __PACKAGE__->meta->make_immutable;
+    no Moose;
+}
+
+{
+    package Op::SimpleParcel;
+    use Moose;
+    extends 'Op';
+
+    has items => (isa => 'ArrayRef[Op]', is => 'ro', required => 1);
+    sub zyg { @{ $_[0]->items } }
+
+    sub code {
+        my ($self, $body) = @_;
+        CgOp::subcall(CgOp::fetch(CgOp::scopedlex('&infix:<,>')),
+            map { $_->cgop($body) } @{ $self->items });
+    }
+
+    __PACKAGE__->meta->make_immutable;
+    no Moose;
+}
+
 {
     package Op::Interrogative;
     use Moose;

test2.pl

@@ -17,11 +17,16 @@
 my class Pair is Enum {
 }
 
-sub _pair($k, $v) { Pair.RAWCREATE("key", $k, "value", $v) }
+sub infix:<< => >>($k, $v) { Pair.RAWCREATE("key", $k, "value", $v) }
 
 is :foo.value, 'Bool::True', ":foo is true";
 is :!foo.value, 'Bool::False', ":!foo is false";
 is :foo<12>.value, '12', ":foo<12> is 12";
 is :foo.key, 'foo', ":foo is foo";
 
+is (foo => 1).key, 'foo', "foo => 1 keeps key";
+is (foo => 1).value, '1', "foo => 1 keeps value";
+is ("foo" => 1).key, 'foo', '"foo" => 1 keeps key';
+is ("foo" => 1).value, '1', '"foo" => 1 keeps value';
+
 done-testing;