Implement $<sym>

Also restructures and simplifies the regex CHECK process.
sorear · Oct 21, 2010 · 2a653c8 · 2a653c8
1 parent 5c30728
commit 2a653c8
Show file tree

Hide file tree

Showing 5 changed files with 61 additions and 37 deletions.
diff --git a/src/Niecza/Actions.pm b/src/Niecza/Actions.pm
@@ -295,7 +295,10 @@ sub quote__S_Q { my ($cl, $M) = @_;
 
 sub quote__S_Slash_Slash { my ($cl, $M) = @_;
     my @lift = $M->{nibble}{_ast}->oplift;
-    { local $::paren = 0; $M->{nibble}{_ast}->check }
+    {
+        local $::paren = 0;
+        $M->{nibble}{_ast}->check
+    }
     my ($rxop, $mb) = Optimizer::RxSimple::run($M->{nibble}{_ast});
     $M->{_ast} = Op::SubDef->new(
         var  => $cl->gensym,
@@ -310,7 +313,6 @@ sub quote__S_Slash_Slash { my ($cl, $M) = @_;
 
 sub encapsulate_regex { my ($cl, $M, $rxop, %args) = @_;
     my @lift = $rxop->oplift;
-    unless ($args{passcap}) { local $::paren = 0; $rxop->check }
     my ($nrxop, $mb) = Optimizer::RxSimple::run($rxop);
     unshift @lift, Op::Bind->new(readonly => 1,
         lhs => Op::Lexical->new(name => '$*GOAL', declaring => 1),
@@ -366,7 +368,7 @@ sub regex_def { my ($cl, $M) = @_;
         }
         $isproto = 1;
     } else {
-        my $m2 = defined($::symtext) ? 'multi' : 'only';
+        my $m2 = defined($symtext) ? 'multi' : 'only';
         if ($::MULTINESS && $::MULTINESS ne $m2) {
             $M->sorry("Inferred multiness disagrees with explicit");
             return;
@@ -398,8 +400,11 @@ sub regex_def { my ($cl, $M) = @_;
         $ast = RxOp::ProtoRedis->new(name => $name);
     }
 
-    { local $::paren = 0; $ast->check }
-    local $::symtext = $symtext;
+    {
+        local $::paren = 0;
+        local $::symtext = $symtext;
+        $ast->check;
+    }
     my $lad = Optimizer::RxSimple::run_lad($ast->lad);
     my @lift = $ast->oplift;
     ($ast, my $mb) = Optimizer::RxSimple::run($ast);
@@ -413,7 +418,7 @@ sub regex_def { my ($cl, $M) = @_;
             class => 'Regex',
             type  => 'regex',
             signature => $sig->for_regex,
-            do => Op::RegexBody->new(sym => $symtext, pre => \@lift,
+            do => Op::RegexBody->new(pre => \@lift,
                 name => ($name // ''), rxop => $ast, canback => $mb)));
 }
 
@@ -750,6 +755,14 @@ sub assertion__S_name { my ($cl, $M) = @_;
     if ($M->{assertion}[0]) {
         $M->{_ast} = $M->{assertion}[0]{_ast};
     } else {
+        if ($name eq 'sym') {
+            $M->{_ast} = RxOp::Sym->new;
+            return;
+        } elsif ($name eq 'before') {
+            $M->{_ast} = RxOp::Before->new(zyg => [$M->{nibbler}[0]{_ast}]);
+            return;
+        }
+
         if ($M->{nibbler}[0]) {
             my $args = [$M->{nibbler}[0]{_ast}];
             $M->{_ast} = RxOp::Subrule->new(zyg => $args, method => $name);

diff --git a/src/Optimizer/RxSimple.pm b/src/Optimizer/RxSimple.pm
@@ -114,19 +114,13 @@ sub RxOp::Cut::rxsimp { my ($self, $cut) = @_;
 }
 
 sub RxOp::Subrule::rxsimp { my ($self, $cut) = @_;
-    if (my $true = $self->true) {
-        return $true->rxsimp($cut);
-    }
     if ($cut) {
         return RxOp::Subrule->new(%$self, selfcut => 1);
     }
     return $self;
 }
 
 sub RxOp::Subrule::mayback { my ($self) = @_;
-    if (my $true = $self->true) {
-        return $true->mayback;
-    }
     return !$self->selfcut;
 }
 

diff --git a/src/RxOp.pm b/src/RxOp.pm
@@ -36,6 +36,36 @@ use CgOp;
     no Moose;
 }
 
+{
+    package RxOp::Sym;
+    use Moose;
+    extends 'RxOp';
+
+    has text => (isa => 'Str', is => 'rw');
+    sub check { $_[0]->text($::symtext) }
+
+    sub code {
+        my ($self, $body) = @_;
+        my $t = $self->text;
+        # We aren't going to make a real Match unless somebody comes up with
+        # a good reason.
+        my $p = CgOp::rxpushcapture(CgOp::string_var($t), "sym");
+        if (length($t) == 1) {
+            $p, CgOp::rxbprim('ExactOne', CgOp::char($t));
+        } else {
+            $p, CgOp::rxbprim('Exact', CgOp::clr_string($t));
+        }
+    }
+
+    sub lad {
+        my ($self) = @_;
+        [ 'Str', $self->text ];
+    }
+
+    __PACKAGE__->meta->make_immutable;
+    no Moose;
+}
+
 {
     package RxOp::String;
     use Moose;
@@ -469,6 +499,7 @@ use CgOp;
     has captures => (isa => 'ArrayRef[Maybe[Str]]', is => 'ro', default => sub { [] });
     has arglist  => (isa => 'Maybe[ArrayRef[Op]]', is => 'ro');
     has selfcut  => (isa => 'Bool', is => 'ro', default => 0);
+    has symtext  => (isa => 'Maybe[Str]', is => 'rw');
 
     sub opzyg { ($_[0]->regex ? ($_[0]->regex) : ()), @{ $_[0]->arglist // [] } }
 
@@ -491,36 +522,19 @@ use CgOp;
                 $::paren = $_ + 1;
             }
         }
+        $self->symtext($::symtext) if $self->method && $self->method eq 'sym';
         if ($self->_passcapzyg) {
+            local $::paren = 0 unless $self->passcap;
             $self->_passcapzyg->check;
         }
         $self->SUPER::check;
     }
 
-    sub true {
-        my ($self) = @_;
-        # all not quite right in the capturey case
-        return unless $self->method;
-        if ($self->method eq 'sym') {
-            return RxOp::String->new(text => $::symtext);
-        }
-        if ($self->method eq 'before') {
-            return RxOp::Before->new(zyg => $self->zyg);
-        }
-        if ($self->method eq 'after') {
-            return RxOp::After->new(zyg => $self->zyg);
-        }
-    }
-
     sub code {
         my ($self, $body) = @_;
         my $bt = $self->label;
         my $sk = $self->label;
 
-        if (my $true = $self->true) {
-            return $true->code($body);
-        }
-
         my @args = Op::CallLike::parsearglist($body, @{ $self->arglist // [] });
 
         my $callf = $self->regex ?
@@ -569,9 +583,6 @@ use CgOp;
 
     sub lad {
         my ($self) = @_;
-        if (my $true = $self->true) {
-            return $true->lad;
-        }
         [ 'Method', $self->method ];
     }
 

diff --git a/test2.pl b/test2.pl
@@ -58,6 +58,12 @@
     is @arr.join("|"), "a|b|c", "Regex.ACCEPTS in list context returns captures";
     $m = "" ~~ / <O( foo => 2 )> /;
     is $m<O><foo>, 2, "<O> is functional";
+
+    $m = (grammar {
+        proto token TOP {*}
+        token TOP:foo { <sym> }
+    }).parse("foo");
+    is $m<sym>, "foo", '$<sym> is functional';
 }
 
 # {

diff --git a/v6/TODO b/v6/TODO
@@ -10,12 +10,10 @@ Cursor.load_lex
 Cursor.makestr
 Cursor.mark_sinks
 Cursor.mixin
-Cursor.O
 Cursor.suppose
 Cursor.trim_heredoc
 List.at-pos(WhateverCode)
 Match.CURSOR
-Match.iterator should return numbered captures
 Match.perl
 Match.synthetic
 Parcel.LISTSTORE
@@ -24,7 +22,6 @@ Highwater stuff
 Audit EXPR, termish, nulltermish, nibble
 self in regexes
 Non-string parameterized role arguments
-$<sym>
 temp $*FOO
 token { $param-role-var }
 Make sure / (\w+) $0 / works
@@ -36,6 +33,7 @@ Change STD to use $<foo> = { 1 }
 circumfix:<[ ]>
 Cursor.deb
 Cursor.lineof
+Cursor.O
 hash literals
 () being Nil
 Bool.Numeric
@@ -54,6 +52,7 @@ infix:<x>
 invert(%hash)
 &item
 &join
+Match.iterator should return numbered captures
 not($bool)
 &note
 pop(@array)
@@ -62,6 +61,7 @@ push(@array, $thing)
 shift(@array)
 &sort
 substr($str,$from,$len)
+$<sym>
 try
 token { :my $var = expr; $var }