Implement <before> and family

sorear · Aug 26, 2010 · a8f84cb · a8f84cb
1 parent ebb3fc7
commit a8f84cb
Show file tree

Hide file tree

Showing 6 changed files with 130 additions and 51 deletions.
diff --git a/lib/SAFE.setting b/lib/SAFE.setting
@@ -931,6 +931,16 @@ sub _rxcut($C, $f, $k) {
     @l && $k(@l.shift);
 }
 
+sub _rxbefore($C, $f, $k) {
+    my @l := gather $f($C, &take);
+    @l && $k($C);
+}
+
+sub _rxnotbefore($C, $f, $k) {
+    my @l := gather $f($C, &take);
+    @l || $k($C);
+}
+
 sub _rxalt($C, $lad, $k, *@alts) {
     sub lbody($ix) { @alts[$ix]($C, $k) }
 

diff --git a/lib/Test.pm6 b/lib/Test.pm6
@@ -64,3 +64,19 @@ sub is($a, $b, $tag) is export { $*TEST-BUILDER.ok($a eq $b, $tag) }
 sub plan($num) is export { $*TEST-BUILDER.plan($num) }
 sub done-testing() is export { $*TEST-BUILDER.done-testing }
 sub done_testing() is export { $*TEST-BUILDER.done-testing }
+
+# TODO standardize me
+sub rxtest($rgx, $rgxname, @y, @n) is export {
+    for @y {
+        my $k = $_ ~~ Pair ?? $_.key !! $_;
+        my $v = $_ ~~ Pair ?? $_.value !! $_;
+        ok $k ~~ $rgx, "$rgxname ~~ $v";
+    }
+    for @n {
+        my $k = $_ ~~ Pair ?? $_.key !! $_;
+        my $v = $_ ~~ Pair ?? $_.value !! $_;
+        ok !($k ~~ $rgx), "$rgxname !~~ $v";
+    }
+}
+
+
diff --git a/src/Niecza/Actions.pm b/src/Niecza/Actions.pm
@@ -620,6 +620,19 @@ sub do_cclass { my ($cl, $M) = @_;
     $M->{_ast} = $rxop;
 }
 
+sub decapturize { my ($cl, $M) = @_;
+    if ($M->{assertion}{assertion}[0]) {
+        $M->sorry("Binding to a method doesn't work like that");
+        return;
+    }
+    if (!$M->{assertion}{_ast}->isa('RxOp::Capture')) {
+        $M->sorry("Internal error in assertion:method parse");
+        return;
+    }
+    RxOp::Capture->new(names => [],
+        zyg => $M->{assertion}{_ast}->zyg);
+}
+
 sub cclass_elem {}
 
 sub assertion {}
@@ -630,9 +643,15 @@ sub assertion__S_name { my ($cl, $M) = @_;
     if ($M->{assertion}[0]) {
         $M->{_ast} = $M->{assertion}[0]{_ast};
     } else {
-        $M->{_ast} = RxOp::CallMethod->new(arglist =>
-            ($M->{arglist}[0] ? $M->{arglist}[0]{_ast} :
-            $M->{nibbler}[0] ? [$M->{nibbler}[0]{_ast}] : []), name => $name);
+        my $args = ($M->{arglist}[0] ? $M->{arglist}[0]{_ast} :
+            $M->{nibbler}[0] ? [$M->{nibbler}[0]{_ast}] : []);
+        if ($name eq 'before') {
+            $M->{_ast} = RxOp::Before->new(zyg => $args);
+        } elsif ($name eq 'after') {
+            $M->{_ast} = RxOp::After->new(zyg => $args);
+        } else {
+            $M->{_ast} = RxOp::CallMethod->new(arglist => $args, name => $name);
+        }
     }
     $M->{_ast} = $cl->rxcapturize($name, $M->{_ast});
 }
@@ -642,29 +661,20 @@ sub assertion__S_method { my ($cl, $M) = @_;
         $M->sorry("Dottyop assertions NYI");
         return;
     }
-    if ($M->{assertion}{assertion}[0]) {
-        $M->sorry("Binding to a method doesn't work like that");
-        return;
-    }
-    if (!$M->{assertion}{_ast}->isa('RxOp::Capture')) {
-        $M->sorry("Internal error in assertion:method parse");
-        return;
-    }
-    $M->{_ast} = RxOp::Capture->new(names => [],
-        zyg => $M->{assertion}{_ast}->zyg);
+    $M->{_ast} = $cl->decapturize($M);
 }
 
 sub assertion__S_Question { my ($cl, $M) = @_;
     if ($M->{assertion}) {
-        $M->{_ast} = RxOp::Before->new(zyg => [$M->{assertion}{_ast}]);
+        $M->{_ast} = RxOp::Before->new(zyg => [$cl->decapturize($M)]);
     } else {
         $M->{_ast} = RxOp::Sequence->new;
     }
 }
 
 sub assertion__S_Bang { my ($cl, $M) = @_;
     if ($M->{assertion}) {
-        $M->{_ast} = RxOp::Before->new(zyg => [$M->{assertion}{_ast}]);
+        $M->{_ast} = RxOp::NotBefore->new(zyg => [$cl->decapturize($M)]);
     } else {
         $M->{_ast} = RxOp::None->new;
     }

diff --git a/src/RxOp.pm b/src/RxOp.pm
@@ -251,8 +251,6 @@ use CgOp;
     use Moose;
     extends 'RxOp';
 
-    # zyg * N
-
     sub op {
         my ($self, $cn, $cont) = @_;
 
@@ -274,6 +272,59 @@ use CgOp;
     no Moose;
 }
 
+{
+    package RxOp::Before;
+    use Moose;
+    extends 'RxOp';
+
+    sub op {
+        my ($self, $cn, $cont) = @_;
+
+        my $icn = Niecza::Actions->gensym;
+        $icn, Op::CallSub->new(
+            invocant => Op::Lexical->new(name => '&_rxbefore'),
+            positionals => [
+                Op::Lexical->new(name => $icn),
+                $self->_close_op($self->zyg->[0]),
+                $self->_close_k($cn, $cont)]);
+    }
+
+    sub lad {
+        my ($self) = @_;
+        CgOp::rawnew('LADSequence', $self->zyg->[0]->lad,
+            CgOp::rawnew('LADImp'));
+    }
+
+    __PACKAGE__->meta->make_immutable;
+    no Moose;
+}
+
+{
+    package RxOp::NotBefore;
+    use Moose;
+    extends 'RxOp';
+
+    sub op {
+        my ($self, $cn, $cont) = @_;
+
+        my $icn = Niecza::Actions->gensym;
+        $icn, Op::CallSub->new(
+            invocant => Op::Lexical->new(name => '&_rxnotbefore'),
+            positionals => [
+                Op::Lexical->new(name => $icn),
+                $self->_close_op($self->zyg->[0]),
+                $self->_close_k($cn, $cont)]);
+    }
+
+    sub lad {
+        my ($self) = @_;
+        CgOp::rawnew('LADNull');
+    }
+
+    __PACKAGE__->meta->make_immutable;
+    no Moose;
+}
+
 {
     package RxOp::Capture;
     use Moose;

diff --git a/test.pl b/test.pl
@@ -2,7 +2,7 @@
 
 use Test;
 
-plan 392;
+plan 406;
 
 ok 1, "one is true";
 ok 2, "two is also true";
@@ -882,19 +882,6 @@
     is foo("bar"), "barbar", "can parse type constraints";
 }
 
-sub rxtest($rgx, $rgxname, @y, @n) {
-    for @y {
-        my $k = $_ ~~ Pair ?? $_.key !! $_;
-        my $v = $_ ~~ Pair ?? $_.value !! $_;
-        ok $k ~~ $rgx, "$rgxname ~~ $v";
-    }
-    for @n {
-        my $k = $_ ~~ Pair ?? $_.key !! $_;
-        my $v = $_ ~~ Pair ?? $_.value !! $_;
-        ok !($k ~~ $rgx), "$rgxname !~~ $v";
-    }
-}
-
 rxtest /x.y/, "x.y", ("xay", "x y"), ("xy", "xaay");
 rxtest /<!>/, '<!>', Nil, ("", "x");
 rxtest /\s/, '\s', (" ", ("\n" => '\n'), ("\r" => '\r'), "\x3000"),
@@ -909,3 +896,28 @@ ($rgx, $rgxname, @y, @n)
 rxtest /a || b/, 'a || b', ("a", "b"), ("c", "");
 rxtest /x [a || aa]: c/, 'x[a||b]:c', ("xac",), ("xaac",);
 
+{
+    my $obj ::= (class {
+        method item() { "item" }
+        method list() { "list" }
+        method hash() { "hash" }
+    }).new;
+
+    is $($obj), "item", '$() calls item';
+    is @($obj), "list", '@() calls list';
+    is %($obj), "hash", '%() calls hash';
+
+    is $$obj, "item", '$$ truncated context';
+    is @$obj, "list", '@$ truncated context';
+    is %$obj, "hash", '%$ truncated context';
+
+    is "x$$obj", "xitem", '$$ interpolation';
+    is "x@$obj", "xlist", '@$ interpolation';
+    is "x%$obj", "xhash", '%$ interpolation';
+}
+
+ok "axy" ~~ / a <before x> \w y / , "before is zero-width";
+ok "axy" ~~ / a <?before x> \w y / , "?before is zero-width";
+ok "azy" ~~ / a <!before x> \w y / , "!before is zero-width";
+ok !("azy" ~~ / a <?before x> \w y /) , "?before x needs x";
+ok !("axy" ~~ / a <!before x> \w y /) , "!before x needs !x";
diff --git a/test2.pl b/test2.pl
@@ -1,24 +1,4 @@
 # vim: ft=perl6
 use Test;
 
-{
-    my $obj ::= (class {
-        method item() { "item" }
-        method list() { "list" }
-        method hash() { "hash" }
-    }).new;
-
-    is $($obj), "item", '$() calls item';
-    is @($obj), "list", '@() calls list';
-    is %($obj), "hash", '%() calls hash';
-
-    is $$obj, "item", '$$ truncated context';
-    is @$obj, "list", '@$ truncated context';
-    is %$obj, "hash", '%$ truncated context';
-
-    is "x$$obj", "xitem", '$$ interpolation';
-    is "x@$obj", "xlist", '@$ interpolation';
-    is "x%$obj", "xhash", '%$ interpolation';
-}
-
 done-testing;