Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
Implement !op, fix CHAIN
  • Loading branch information
@sorear
sorear committed Oct 20, 2010
1 parent f9817db commit 9d541a8
Show file tree
Hide file tree
Showing 5 changed files with 132 additions and 107 deletions.
50 changes: 50 additions & 0 deletions lib/SAFE.setting
View file
Expand Up @@ -81,6 +81,13 @@ my class Cool {
method iterator() { self.flat.iterator }
method join($sep) { self.flat.join($sep) }
}
my class Capture {
has $!positionals;
has $!named;
method Capture () { self }
}
# }}}
# Scalar types {{{
my class Num is Cool {
Expand Down Expand Up @@ -328,6 +335,9 @@ sub assignop($fn) {
$lhs = $fn($lhs, $rhs)
}
}
sub notop(&fn) { -> \$x, \$y { !(fn($x,$y)) } }
# }}}
# Aggregate types {{{
# Parcel: immutable list of boxes which have no context - may flatten, may
Expand Down Expand Up @@ -365,6 +375,14 @@ my class Parcel is Cool {
(box Num (cast num (fvarlist_length (unbox fvarlist (@ {self})))))
} }
method Capture () {
Q:CgOp {
(letn n (obj_newblank (obj_llhow (@ {Capture})))
(setslot positionals (l n) (unbox fvarlist (@ {self})))
(ns (l n)))
}
}
method iterator() {
my class ParcelIterator is Iterator {
has $.reify;
Expand Down Expand Up @@ -409,6 +427,15 @@ my class List is Cool {
Seq.SETUP(True, (&infix:<,>(self.iterator)));
}
method Capture () {
Q:CgOp {
(letn n (obj_newblank (obj_llhow (@ {Capture})))
(setslot positionals (l n) (vvarlist_to_fvarlist
(getslot items vvarlist (@ {self.eager}))))
(ns (l n)))
}
}
#| Takes an object and applies whatever semantics the List subclass
#| needs to apply on stuff out of the iterator stack
method _elem(\$x) { $x }
Expand Down Expand Up @@ -593,6 +620,16 @@ my class Hash {
};
}
method Capture () {
Q:CgOp {
(letn n (obj_newblank (obj_llhow (@ {Capture})))
(setslot positionals (l n) (fvarlist_new))
(setslot named (l n) (varhash_dup
(unbox varhash (@ {self}))))
(ns (l n)))
}
}
method keys() {
Q:CgOp {
(letn n (obj_newblank (obj_llhow (@ {List})))
Expand Down Expand Up @@ -666,6 +703,18 @@ my class Enum is Cool {
has $.key;
has $.value;
method Capture () {
Q:CgOp {
(letn n (obj_newblank (obj_llhow (@ {Capture})))
d (varhash_new)
(setslot positionals (l n) (fvarlist_new))
(setslot named (l n) (l d))
(varhash_setindex (unbox str (@ {$!key.Str}))
(l d) {$!value})
(ns (l n)))
}
}
method kv() {
($.key, $.value);
}
Expand Down Expand Up @@ -772,6 +821,7 @@ my class Cursor {
(cursor_item (cast cursor (@ {self})) (unbox str (@ {$k.Str})))
} }
method at-pos($i) { self.at-key($i) }
token alpha { <+INTERNAL::alpha> }
}
my class Match {
Expand Down
37 changes: 33 additions & 4 deletions src/Niecza/Actions.pm
View file
Expand Up @@ -1098,6 +1098,33 @@ sub circumfix__S_sigil { my ($cl, $M) = @_;
$M->{_ast} = $cl->docontext($M, $M->{sigil}->Str, $M->{_ast});
}

sub infix_prefix_meta_operator { }
sub infix_prefix_meta_operator__S_Bang { my ($cl, $M) = @_;
$M->{_ast} = Op::CallSub->new(
invocant => Op::Lexical->new(name => '&notop'),
args => [ $M->{infixish}{infix}{_ast} ]);
}
sub infix_prefix_meta_operator__S_R { my ($cl, $M) = @_;
$M->{_ast} = Op::CallSub->new(
invocant => Op::Lexical->new(name => '&reverseop'),
args => [ $M->{infixish}{infix}{_ast} ]);
}
sub infix_prefix_meta_operator__S_Z { my ($cl, $M) = @_;
$M->{_ast} = Op::CallSub->new(
invocant => Op::Lexical->new(name => '&zipop'),
args => [ $M->{infixish}{infix}{_ast} ]);
}
sub infix_prefix_meta_operator__S_S { my ($cl, $M) = @_;
$M->{_ast} = Op::CallSub->new(
invocant => Op::Lexical->new(name => '&seqop'),
args => [ $M->{infixish}{infix}{_ast} ]);
}
sub infix_prefix_meta_operator__S_X { my ($cl, $M) = @_;
$M->{_ast} = Op::CallSub->new(
invocant => Op::Lexical->new(name => '&crossop'),
args => [ $M->{infixish}{_ast} ]);
}

sub infixish { my ($cl, $M) = @_;
if ($M->{colonpair}) {
return; # handled in POST
Expand Down Expand Up @@ -1153,20 +1180,22 @@ sub INFIX { my ($cl, $M) = @_;
}

sub CHAIN { my ($cl, $M) = @_;
my $op = '&infix:<' . $M->{chain}[1]{sym} . '>';
my @args;
my @ops;
for my $i (0 .. scalar @{ $M->{chain} }) {
if (($i % 2) == 0) {
if ($i % 2) {
push @ops, $M->{chain}[$i]{infix}{_ast};
} else {
push @args, $M->{chain}[$i]{_ast};
}
}

my ($st, @vargs) = $cl->whatever_precheck($op, @args);
my ($st, @vargs) = $cl->whatever_precheck('', @args);

my @pairwise;
while (@vargs >= 2) {
push @pairwise, Op::CallSub->new(node($M),
invocant => Op::Lexical->new(name => $op),
invocant => shift(@ops),
positionals => [ $vargs[0], $vargs[1] ]);
shift @vargs;
}
Expand Down
49 changes: 48 additions & 1 deletion test.pl
View file
Expand Up @@ -2,7 +2,7 @@

use Test;

plan 581;
plan 608;

ok 1, "one is true";
ok 2, "two is also true";
Expand Down Expand Up @@ -1184,3 +1184,50 @@
is { :a(1) }.<a>, 1, "hash constructors work w/ colons";
is { a => 1, b => 2 }.<b>, 2, "hash constructors work w/ lists";
ok { } ~~ Hash, "hash constructors work w/ nothing";
ok !('xy' ~~ /x <{ False }> y/), '<{False}> blocks a match';
ok 'xy' ~~ /x <{ True }> y/, '<{True}> does not affect it';
ok (1 < 3 > 2), "CHAIN works with dissimilar ops";
{
my $b = "oo";
is ("foox" ~~ /f$b/), "foo", '$x matches contents in a regex';
}
{
sub f1(:$x) { $x }
is f1(|("x" => 2)), 2, "can flatten pairs";
is f1(|{"x" => 2}), 2, "can flatten hashes";
sub f2($x,$) { $x }
is f2(|[1,2]), 1, "can flatten lists";
is f2(|(1,2)), 1, "can flatten parcels";
}
rxtest / <alpha> / , '<alpha>', ('a', 'A', "\x4E00"), ("+", "1", " ");
{
my $m = "" ~~ / $<foo> = { 2 + 2 } $<bar> = {"x"} $<bar> = {"y"} /;
is $m<foo>, 4, "value aliasing works (sing)";
is $m<bar>, "x y", "value aliasing works (plur)";
$m = "fo" ~~ / (.) (.) /;
is $m[0], "f", "numbered captures work";
is $m[1], "o", "capture auto-numbering works";
$m = "foo" ~~ / (.) ( (.) (.) ) /;
is $m[1], "oo", "outer capture sees inner";
is $m[1][1], "o", "nested numeric captures work";
$m = "def" ~~ /<a=.alpha> $<moo> = [ <b=.alpha> <c=.alpha> ]/;
is $m<a>, "d", "aliasing works";
is $m<c>, "f", "aliased [] transparent to captures";
is $m<moo>, "ef", "aliased [] captures string";
ok !$m<moo><b>, "no spurious nested captures";
my $save;
"()" ~~ / '(' ~ ')' { $save = $*GOAL } /;
is $save, ')', 'Setting $*GOAL works';
}
ok 1 !== 2, "infix_prefix_meta_operator:<!> works (T)";
ok !(1 !== 1), "infix_prefix_meta_operator:<!> works (F)";
101 changes: 0 additions & 101 deletions test2.pl
View file
Expand Up @@ -2,107 +2,6 @@
use Test;
use MONKEY_TYPING;

my class Capture {
has $!positionals;
has $!named;

method Capture () { self }
}

augment class List {
method Capture () {
Q:CgOp {
(letn n (obj_newblank (obj_llhow (@ {Capture})))
(setslot positionals (l n) (vvarlist_to_fvarlist
(getslot items vvarlist (@ {self.eager}))))
(ns (l n)))
}
}
}
augment class Parcel {
method Capture () {
Q:CgOp {
(letn n (obj_newblank (obj_llhow (@ {Capture})))
(setslot positionals (l n) (unbox fvarlist (@ {self})))
(ns (l n)))
}
}
}

augment class Enum {
method Capture () {
Q:CgOp {
(letn n (obj_newblank (obj_llhow (@ {Capture})))
d (varhash_new)
(setslot positionals (l n) (fvarlist_new))
(setslot named (l n) (l d))
(varhash_setindex (unbox str (@ {$!key.Str}))
(l d) {$!value})
(ns (l n)))
}
}
}
augment class Hash {
method Capture () {
Q:CgOp {
(letn n (obj_newblank (obj_llhow (@ {Capture})))
(setslot positionals (l n) (fvarlist_new))
(setslot named (l n) (varhash_dup
(unbox varhash (@ {self}))))
(ns (l n)))
}
}
}

augment class Cursor {
token alpha { <+INTERNAL::alpha> }
}

ok !('xy' ~~ /x <{ False }> y/), '<{False}> blocks a match';
ok 'xy' ~~ /x <{ True }> y/, '<{True}> does not affect it';

{
my $b = "oo";
is ("foox" ~~ /f$b/), "foo", '$x matches contents in a regex';
}

{
sub f1(:$x) { $x }
is f1(|("x" => 2)), 2, "can flatten pairs";
is f1(|{"x" => 2}), 2, "can flatten hashes";
sub f2($x,$) { $x }
is f2(|[1,2]), 1, "can flatten lists";
is f2(|(1,2)), 1, "can flatten parcels";
}

rxtest / <alpha> / , '<alpha>', ('a', 'A', "\x4E00"), ("+", "1", " ");

{
my $m = "" ~~ / $<foo> = { 2 + 2 } $<bar> = {"x"} $<bar> = {"y"} /;
is $m<foo>, 4, "value aliasing works (sing)";
is $m<bar>, "x y", "value aliasing works (plur)";

$m = "fo" ~~ / (.) (.) /;
is $m[0], "f", "numbered captures work";
is $m[1], "o", "capture auto-numbering works";

$m = "foo" ~~ / (.) ( (.) (.) ) /;
is $m[1], "oo", "outer capture sees inner";
is $m[1][1], "o", "nested numeric captures work";

$m = "def" ~~ /<a=.alpha> $<moo> = [ <b=.alpha> <c=.alpha> ]/;
is $m<a>, "d", "aliasing works";
is $m<c>, "f", "aliased [] transparent to captures";
is $m<moo>, "ef", "aliased [] captures string";
ok !$m<moo><b>, "no spurious nested captures";

my $save;
"()" ~~ / '(' ~ ')' { $save = $*GOAL } /;
is $save, ')', 'Setting $*GOAL works';
}

# {
# our role Stop4717[$a] {
# token foo { $a }
Expand Down
2 changes: 1 addition & 1 deletion v6/TODO
View file
Expand Up @@ -19,7 +19,6 @@ Match.iterator should return numbered captures
Match.perl
Match.synthetic
Parcel.LISTSTORE
$*GOAL handling XXX
Highwater stuff
Audit EXPR, termish, nibble
Change STD to use $<foo> = { 1 }
Expand Down Expand Up @@ -47,6 +46,7 @@ defined($thing)
$*FOO as a parameter
func(|($key => $value))
gt, lt, leg, etc
$*GOAL handling
Hash.keys &keys
Hash.LISTSTORE
infix:<x>
Expand Down

0 comments on commit 9d541a8

Please sign in to comment.