Implement the REGEX COMPILER!

sorear · Jul 22, 2010 · a5170a7 · a5170a7
1 parent 0067ab2
commit a5170a7
Show file tree

Hide file tree

Showing 3 changed files with 75 additions and 2 deletions.
diff --git a/Niecza/Actions.pm b/Niecza/Actions.pm
@@ -205,7 +205,11 @@ sub quant_atom_list { my ($cl, $M) = @_;
 sub nibbler { my ($cl, $M) = @_;
     if ($M->isa('STD::Regex')) {
         my $slot = $cl->gensym;
-        $M->{_ast} = Op::Regex->new(name => $cl->gensym, rxop => $M->{EXPR}{_ast});
+        # TODO should be a real pass.
+        $M->{_ast} = Op::CallMethod->new(name => 'bless',
+            receiver => Op::Lexical->new(name => 'Regex'),
+            positionals => [
+                RxOp::Export->new(zyg => [$M->{EXPR}{_ast}])->closure ]);
     } elsif ($M->isa('Niecza::Grammar::CgOp')) {
         # XXX We don't interpret the code, so we can't tell if it's actually
         # using variables, but still, it probably is.

diff --git a/RxOp.pm b/RxOp.pm
@@ -10,6 +10,22 @@ use CgOp;
 
     has zyg => (isa => 'ArrayRef[RxOp]', is => 'ro');
 
+    my $i = 0;
+    sub _closurize {
+        my ($self, $op) = @_;
+        Op::SubDef->new(var => 'rx!' . ($i++), body =>
+            Body->new(
+                type      => 'regex',
+                signature => Sig->new(params => [ Sig::Parameter->new(
+                    target => Sig::Target->new(slot => '$¢'))]),
+                do        => $op));
+    }
+
+    sub closure {
+        my ($self) = @_;
+        $self->_closurize($self->op);
+    }
+
     __PACKAGE__->meta->make_immutable;
     no Moose;
 }
@@ -21,6 +37,33 @@ use CgOp;
 
     has text => (isa => 'Str', is => 'ro', required => 1);
 
+    sub op {
+        my ($self) = @_;
+        Op::CallSub->new(
+            invocant => Op::Lexical->new(name => '&_rxstr'),
+            positionals => [
+                Op::Lexical->new(name => '$¢'),
+                Op::StringLiteral->new(text => $self->text)]);
+    }
+
+    __PACKAGE__->meta->make_immutable;
+    no Moose;
+}
+
+{
+    package RxOp::Export;
+    use Moose;
+    extends 'RxOp';
+
+    # zyg * 1
+
+    sub op {
+        my ($self) = @_;
+        Op::CallSub->new(
+            invocant => Op::Lexical->new(name => '&_rxexport'),
+            positionals => [$self->zyg->[0]->op]);
+    }
+
     __PACKAGE__->meta->make_immutable;
     no Moose;
 }
@@ -34,6 +77,16 @@ use CgOp;
     # ? + * only
     # zyg * 1
 
+    my %qf = ( '+', 'plus', '*', 'star', '?', 'opt' );
+    sub op {
+        my ($self) = @_;
+        Op::CallSub->new(
+            invocant => Op::Lexical->new(name => '&_rx' . $qf{$self->type}),
+            positionals => [
+                Op::Lexical->new(name => '$¢'),
+                $self->zyg->[0]->closure]);
+    }
+
     __PACKAGE__->meta->make_immutable;
     no Moose;
 }
@@ -45,6 +98,21 @@ use CgOp;
 
     # zyg * N
 
+    sub op {
+        my ($self) = @_;
+        my @zyg = map { $_->op } @{ $self->zyg };
+
+        while (@zyg >= 2) {
+            my $r = pop @zyg;
+            my $l = pop @zyg;
+            push @zyg, Op::CallSub->new(
+                invocant    => Op::Lexical->new(name => '&_rxlazymap'),
+                positionals => [ $l, $self->_closurize($r) ]);
+        }
+
+        $zyg[0] || Op::Lexical->new(name => '$¢');
+    }
+
     __PACKAGE__->meta->make_immutable;
     no Moose;
 }

diff --git a/rxwork.pl b/rxwork.pl
@@ -113,7 +113,8 @@ ($C, $str)
 }
 
 # regex { a b* c }
-my $rx = Regex.bless(sub ($C) { _rxexport(_rxlazymap(_rxstr($C, 'a'), sub ($C) { _rxlazymap(_rxstar($C, sub ($C) { _rxstr($C, 'b') }), sub ($C) { _rxstr($C, 'c') }) })) });
+#my $rx = Regex.bless(sub ($C) { _rxexport(_rxlazymap(_rxstr($C, 'a'), sub ($C) { _rxlazymap(_rxstar($C, sub ($C) { _rxstr($C, 'b') }), sub ($C) { _rxstr($C, 'c') }) })) });
+my $rx = /ab*c/;
 
 say "xaaabc" ~ ("xaaabc" ~~ $rx);
 say "xbc"    ~ ("xbc" ~~ $rx);