From 8ea4ceda744c4ea30c22211a24254f3ff3695c5f Mon Sep 17 00:00:00 2001
From: Stefan O'Rear <stefanor@cox.net>
Date: Mon, 9 Aug 2010 23:02:32 -0700
Subject: [PATCH] Implement <foo> and <.foo> in regexes

---
 RxOp.pm      | 25 ++++++++++++-------------
 SAFE.setting | 22 ++++++++++++++++++++++
 test.pl      | 28 ++++++++++++++++++++++++++-
 test2.pl     | 53 ----------------------------------------------------
 4 files changed, 61 insertions(+), 67 deletions(-)

diff --git a/RxOp.pm b/RxOp.pm
index c89a78af..41fdaddd 100644
--- a/RxOp.pm
+++ b/RxOp.pm
@@ -137,23 +137,25 @@ use CgOp;
     has names => (isa => 'ArrayRef[Maybe[Str]]', is => 'ro', required => 1);
 
     sub op {
-        my ($self) = @_;
+        my ($self, $cn, $cont) = @_;
+        my $icn = Niecza::Actions->gensym;
         my @n = @{ $self->names };
         for (@n) {
             $::parennum = $_ if defined($_) && $_ =~ /^[0-9]+$/;
             $_ = $::parennum++ if !defined($_);
         }
-        Op::CallSub->new(
+        $icn, Op::CallSub->new(
             invocant => Op::Lexical->new(name => '&_rxbind'),
             positionals => [
-                Op::Lexical->new(name => '$¢'),
+                Op::Lexical->new(name => $icn),
                 Op::CallSub->new(
                     invocant => Op::Lexical->new(name => '&infix:<,>'),
                     positionals => [
                         map { Op::StringLiteral->new(text => $_) }
                             @{ $self->names }
                     ]),
-                $self->zyg->[0]->closure]);
+                $self->_close_op($self->zyg->[0]),
+                $self->_close_k($cn, $cont)]);
     }
 
     __PACKAGE__->meta->make_immutable;
@@ -168,17 +170,14 @@ use CgOp;
     has name => (isa => 'Str', is => 'ro', required => 1);
 
     sub op {
-        my ($self) = @_;
-        Op::CallSub->new(
+        my ($self, $cn, $cont) = @_;
+        my $icn = Niecza::Actions->gensym;
+        $icn, Op::CallSub->new(
             invocant => Op::Lexical->new(name => '&_rxcall'),
             positionals => [
-                Op::Lexical->new(name => '$¢'),
-                Op::SubDef->new(var => Niecza::Actions->gensym, body =>
-                    Body->new(
-                        type        => 'sub',
-                        signature   => Sig->simple('$¢'),
-                        do          => Op::CallMethod->new(name => $self->name,
-                            receiver => Op::Lexical->new(name => '$¢'))))]);
+                Op::CallMethod->new(name => $self->name,
+                    receiver => Op::Lexical->new(name => $icn)),
+                $self->_close_k($cn, $cont)]);
     }
 
     __PACKAGE__->meta->make_immutable;
diff --git a/SAFE.setting b/SAFE.setting
index fb073c72..6bf1f317 100644
--- a/SAFE.setting
+++ b/SAFE.setting
@@ -936,4 +936,26 @@ my class Grammar is Cursor {
     }
 }
 
+sub _rxcall(@list, $k) {
+    $k(@list.shift) while @list;
+}
+
+# A call to a subrule could return a cursor of a different type, or with
+# unwanted subcaptures that need to be cleared for <.foo>
+sub _rxbind($C, @names, $fun, $k) {
+    $fun($C, -> $C2 {
+        my $C3 = Q:CgOp {
+            (box (@ (l $C)) (rawcall (unbox Cursor (@ (l $C2)))
+                SetCaps (getfield captures (unbox Cursor (@ (l $C))))))
+        };
+        for @names -> $n { #OK
+            $C3 = Q:CgOp {
+                (box (@ (l $C3)) (rawcall (unbox Cursor (@ (l $C3)))
+                    Bind (unbox String (@ (l $n))) (l $C3)))
+            };
+        }
+        $k($C3);
+    });
+}
+
 {YOU_ARE_HERE}
diff --git a/test.pl b/test.pl
index 835d513f..e8fd774d 100644
--- a/test.pl
+++ b/test.pl
@@ -2,7 +2,7 @@
 
 use Test;
 
-plan 231;
+plan 237;
 
 ok 1, "one is true";
 ok 2, "two is also true";
@@ -610,3 +610,29 @@
     ok !@l1, "no more values";
     ok $y, "querying that fact finished the block";
 }
+
+{
+    my grammar G1 {
+        regex TOP { <.foo> }
+        regex foo { x }
+    }
+
+    ok G1.parse("x"), "subrules work (positive)";
+    ok !G1.parse("y"), "subrules work (negative)";
+
+    my grammar G2 {
+        regex TOP { y <.foo> <.foo> y }
+        regex foo { x }
+    }
+
+    ok G2.parse("yxxy"), "subrule position tracking works";
+    ok !G2.parse("yxy"), "subrule position tracking works (2)";
+
+    my grammar G3 {
+        regex TOP { <moo> }
+        regex moo { x }
+    }
+
+    ok G3.parse("x"), "capturing subrules work (positive)";
+    ok !G3.parse("y"), "capturing subrules work (negative)";
+}
diff --git a/test2.pl b/test2.pl
index e855eb34..a82920e2 100644
--- a/test2.pl
+++ b/test2.pl
@@ -1,57 +1,4 @@
 # vim: ft=perl6
 use Test;
 
-# maybe should take a method name?
-sub _rxcall($C, $fun) {
-    my @list := $fun($C);
-    sub () { @list ?? @list.shift !! Any; }
-}
-
-# A call to a subrule could return a cursor of a different type, or with
-# unwanted subcaptures that need to be cleared for <.foo>
-sub _rxbind($C, @names, $fun) {
-    my $it = $fun($C);
-    sub {
-        if my $v = $it() { #OK
-            my $nC = Q:CgOp {
-                (box (@ (l $C)) (rawcall (unbox Cursor (@ (l $v)))
-                    SetCaps (getfield captures (unbox Cursor (@ (l $C))))))
-            };
-            for @names -> $n { #OK
-                $nC = Q:CgOp {
-                    (box (@ (l $nC)) (rawcall (unbox Cursor (@ (l $nC)))
-                        Bind (unbox String (@ (l $n))) (l $v)))
-                };
-            }
-            $nC;
-        } else {
-            Any
-        }
-    }
-}
-
-my grammar G1 {
-    regex TOP { <.foo> }
-    regex foo { x }
-}
-
-ok G1.parse("x"), "subrules work (positive)";
-ok !G1.parse("y"), "subrules work (negative)";
-
-my grammar G2 {
-    regex TOP { y <.foo> <.foo> y }
-    regex foo { x }
-}
-
-ok G2.parse("yxxy"), "subrule position tracking works";
-ok !G2.parse("yxy"), "subrule position tracking works (2)";
-
-my grammar G3 {
-    regex TOP { <moo> }
-    regex moo { x }
-}
-
-ok G3.parse("x"), "capturing subrules work (positive)";
-ok !G3.parse("y"), "capturing subrules work (negative)";
-
 done-testing;