Permalink
Browse files

Perlito - perl6 - tree grammar modules

  • Loading branch information...
1 parent 48991b3 commit bd84de4f05b1c3c9a278dad97690e9edd5e52ae1 @fglock committed Oct 15, 2013
Showing with 257 additions and 178 deletions.
  1. +40 −178 misc/tree_grammar.pl
  2. +99 −0 src5/lib/Perlito5/Perl6/TreeGrammar.pm
  3. +118 −0 src5/lib/Perlito5/TreeGrammar.pm
View
218 misc/tree_grammar.pl
@@ -1,56 +1,46 @@
package main {
use Data::Dumper;
use strict;
+ use Perlito5::TreeGrammar;
my $in = eval join( '', <> );
print Dumper $in;
my ( $rule, $result );
$rule = TreeGrammar::AST::is_sub(
- [
- Action => sub {
+ [ Action => sub {
my $sub = $_[0];
my $stmts;
my $var;
- TreeGrammar::render(
- [
- Lookup => 'block',
- [
- Progn => [ Action => sub { $stmts = $_[0] } ],
- [
- Star => [
- Index => 0,
- TreeGrammar::AST::operator_eq(
- 'infix:<=>',
- [
- Lookup => 'arguments',
- [
- And => [
- Index => 0,
- TreeGrammar::AST::my_var(
- [
- Action => sub {
- $var = $_[0]->{var};
- }
- ]
- )
- ],
- [
- Index => 1,
- TreeGrammar::AST::shift_arg()
- ],
- [
- Action => sub {
- push @{ $sub->{args} }, $var;
- shift @$stmts;
- }
- ]
- ]
- ]
- )
- ]
- ]
+ Perlito5::TreeGrammar::render(
+ [ Lookup => 'block',
+ [ Progn => [ Action => sub { $stmts = $_[0] } ],
+ [ Star => [
+ Index => 0,
+ TreeGrammar::AST::operator_eq( 'infix:<=>',
+ [ Lookup => 'arguments',
+ [ And => [ Index => 0,
+ TreeGrammar::AST::my_var(
+ [ Action => sub {
+ $var = $_[0]->{var};
+ }
+ ]
+ )
+ ],
+ [ Index => 1,
+ TreeGrammar::AST::shift_arg()
+ ],
+ [ Action => sub {
+ push @{ $sub->{args} }, $var;
+ shift @$stmts;
+ }
+ ]
+ ]
+ ]
+ )
+ ]
+ ]
]
],
$sub
@@ -59,7 +49,7 @@ package main {
]
);
- $result = TreeGrammar::scan( $rule, $in );
+ $result = Perlito5::TreeGrammar::scan( $rule, $in );
print "result $result\n";
print Dumper $in;
@@ -69,48 +59,39 @@ package TreeGrammar::AST {
use strict;
sub is_sub {
- [
- Ref => 'Perlito5::AST::Sub',
+ [ Ref => 'Perlito5::AST::Sub',
( @_ ? [ Progn => @_ ] : () )
];
}
sub named_sub {
- [
- Ref => 'Perlito5::AST::Sub',
- [
- And => [ Lookup => 'name', [ Not => [ Value => '' ] ] ],
+ [ Ref => 'Perlito5::AST::Sub',
+ [ And => [ Lookup => 'name', [ Not => [ Value => '' ] ] ],
( @_ ? [ Progn => @_ ] : () )
]
];
}
sub operator_eq {
my $name = shift;
- [
- Ref => 'Perlito5::AST::Apply',
- [
- And => [ Lookup => 'code', [ Value => $name ] ],
+ [ Ref => 'Perlito5::AST::Apply',
+ [ And => [ Lookup => 'code', [ Value => $name ] ],
( @_ ? [ Progn => @_ ] : () )
]
];
}
sub my_var {
- [
- Ref => 'Perlito5::AST::Decl',
- [
- And => [ Lookup => 'decl', [ Value => 'my' ] ],
+ [ Ref => 'Perlito5::AST::Decl',
+ [ And => [ Lookup => 'decl', [ Value => 'my' ] ],
( @_ ? [ Progn => @_ ] : () )
]
];
}
sub shift_arg {
- [
- Ref => 'Perlito5::AST::Apply',
- [
- And => [ Lookup => 'code', [ Value => 'shift' ] ],
+ [ Ref => 'Perlito5::AST::Apply',
+ [ And => [ Lookup => 'code', [ Value => 'shift' ] ],
# TODO - bareword => 1, arguments => [], namespace => ''
# or arguments => [ @_ ]
@@ -121,123 +102,4 @@ package TreeGrammar::AST {
}
-package TreeGrammar {
- use Data::Dumper;
- use strict;
-
- my %dispatch;
- INIT {
- %dispatch = (
- Ref => \&Ref, # Ref => 'Perlito5::AST::Apply'
- Lookup => \&Lookup, # Lookup => 'namespace'
- Index => \&Index, # Index => '0'
- Value => \&Value, # Value => '123'
- And => \&And,
- Or => \&Or,
- Not => \&Not,
- Action => \&Action,
- Progn => \&Progn, # same as in Lisp
- Star => \&Star, # same as in regex
- );
- }
-
- sub render {
- my ( $rule, $node ) = @_;
- return $dispatch{ $rule->[0] }->( $rule, $node );
- }
-
- sub scan {
- my ( $rule, $node ) = @_;
- render( $rule, $node ) if $rule;
- if ( ref($node) eq 'ARRAY' ) {
- scan( $rule, $_ ) for @$node;
- }
- elsif ( ref($node) ) {
- scan( $rule, $_ ) for values %$node;
- }
- return;
- }
- sub Action {
- my ( $rule, $node ) = @_;
- $rule->[1]->($node);
- return 1;
- }
-
- sub Not {
- my ( $rule, $node ) = @_;
- my $result;
- render( $rule->[1], $node ) && return;
- return 1;
- }
-
- sub Star {
- my ( $rule, $node ) = @_;
- my $result;
- while (1) {
- render( $rule->[1], $node ) || return;
- }
- }
-
- sub Progn {
- my ( $rule, $node ) = @_;
- my $result;
- for ( @$rule[ 1 .. $#$rule ] ) {
- $result = render( $_, $node );
- }
- return $result;
- }
-
- sub And {
- my ( $rule, $node ) = @_;
- my $result;
- for ( @$rule[ 1 .. $#$rule ] ) {
- $result = render( $_, $node ) or return;
- }
- return $result;
- }
-
- sub Or {
- my ( $rule, $node ) = @_;
- my $result;
- for ( @$rule[ 1 .. $#$rule ] ) {
- $result = render( $_, $node ) and return $result;
- }
- return;
- }
-
- sub Ref {
- my ( $rule, $node ) = @_;
- return if ref($node) ne $rule->[1];
- return 1 if !$rule->[2];
- return render( $rule->[2], $node );
- }
-
- sub Lookup {
- my ( $rule, $node ) = @_;
- return
- if !ref($node)
- || ref($node) eq 'ARRAY'
- || !exists( $node->{ $rule->[1] } );
- return 1 if !$rule->[2];
- return render( $rule->[2], $node->{ $rule->[1] } );
- }
-
- sub Index {
- my ( $rule, $node ) = @_;
- return
- if !ref($node)
- || ref($node) ne 'ARRAY'
- || !exists( $node->[ $rule->[1] ] );
- return 1 if !$rule->[2];
- return render( $rule->[2], $node->[ $rule->[1] ] );
- }
-
- sub Value {
- my ( $rule, $node ) = @_;
- return if ref($node) || $node ne $rule->[1];
- return 1 if !$rule->[2];
- return render( $rule->[2], $node );
- }
-
-}
View
99 src5/lib/Perlito5/Perl6/TreeGrammar.pm
@@ -0,0 +1,99 @@
+package Perlito5::Perl6::TreeGrammar;
+use Data::Dumper;
+use strict;
+use Perlito5::TreeGrammar;
+
+sub refactor_sub_arguments {
+ my ($class, $in) = @_;
+ my ( $rule, $result );
+
+ $rule = Perlito5::Perl6::TreeGrammar::is_sub(
+ [ Action => sub {
+ my $sub = $_[0];
+ my $stmts;
+ my $var;
+ Perlito5::TreeGrammar::render(
+ [ Lookup => 'block',
+ [ Progn => [ Action => sub { $stmts = $_[0] } ],
+ [ Star => [
+ Index => 0,
+ Perlito5::Perl6::TreeGrammar::operator_eq( 'infix:<=>',
+ [ Lookup => 'arguments',
+ [ And => [ Index => 0,
+ Perlito5::Perl6::TreeGrammar::my_var(
+ [ Action => sub {
+ $var = $_[0]->{var};
+ }
+ ]
+ )
+ ],
+ [ Index => 1,
+ Perlito5::Perl6::TreeGrammar::shift_arg()
+ ],
+ [ Action => sub {
+ push @{ $sub->{args} }, $var;
+ shift @$stmts;
+ }
+ ]
+ ]
+ ]
+ )
+ ]
+ ]
+ ]
+ ],
+ $sub
+ );
+ }
+ ]
+ );
+
+ $result = Perlito5::TreeGrammar::scan( $rule, $in );
+ # print "result $result\n";
+ # print Dumper $in;
+}
+
+sub is_sub {
+ [ Ref => 'Perlito5::AST::Sub',
+ ( @_ ? [ Progn => @_ ] : () )
+ ];
+}
+
+sub named_sub {
+ [ Ref => 'Perlito5::AST::Sub',
+ [ And => [ Lookup => 'name', [ Not => [ Value => '' ] ] ],
+ ( @_ ? [ Progn => @_ ] : () )
+ ]
+ ];
+}
+
+sub operator_eq {
+ my $name = shift;
+ [ Ref => 'Perlito5::AST::Apply',
+ [ And => [ Lookup => 'code', [ Value => $name ] ],
+ ( @_ ? [ Progn => @_ ] : () )
+ ]
+ ];
+}
+
+sub my_var {
+ [ Ref => 'Perlito5::AST::Decl',
+ [ And => [ Lookup => 'decl', [ Value => 'my' ] ],
+ ( @_ ? [ Progn => @_ ] : () )
+ ]
+ ];
+}
+
+sub shift_arg {
+ [ Ref => 'Perlito5::AST::Apply',
+ [ And => [ Lookup => 'code', [ Value => 'shift' ] ],
+
+ # TODO - bareword => 1, arguments => [], namespace => ''
+ # or arguments => [ @_ ]
+ ( @_ ? [ Progn => @_ ] : () )
+ ]
+ ];
+}
+
+1;
+
View
118 src5/lib/Perlito5/TreeGrammar.pm
@@ -0,0 +1,118 @@
+package Perlito5::TreeGrammar;
+use Data::Dumper;
+use strict;
+
+my %dispatch = (
+ Ref => sub { Ref(@_) }, # Ref => 'Perlito5::AST::Apply'
+ Lookup => sub { Lookup(@_) }, # Lookup => 'namespace'
+ Index => sub { Index(@_) }, # Index => '0'
+ Value => sub { Value(@_) }, # Value => '123'
+ And => sub { And(@_) },
+ Or => sub { Or(@_) },
+ Not => sub { Not(@_) },
+ Action => sub { Action(@_) },
+ Progn => sub { Progn(@_) }, # same as in Lisp
+ Star => sub { Star(@_) }, # same as in regex
+ );
+
+sub render {
+ my ( $rule, $node ) = @_;
+ return $dispatch{ $rule->[0] }->( $rule, $node );
+}
+
+sub scan {
+ my ( $rule, $node ) = @_;
+ render( $rule, $node ) if $rule;
+ if ( ref($node) eq 'ARRAY' ) {
+ scan( $rule, $_ ) for @$node;
+ }
+ elsif ( ref($node) ) {
+ scan( $rule, $_ ) for values %$node;
+ }
+ return;
+}
+
+sub Action {
+ my ( $rule, $node ) = @_;
+ $rule->[1]->($node);
+ return 1;
+}
+
+sub Not {
+ my ( $rule, $node ) = @_;
+ my $result;
+ render( $rule->[1], $node ) && return;
+ return 1;
+}
+
+sub Star {
+ my ( $rule, $node ) = @_;
+ my $result;
+ while (1) {
+ render( $rule->[1], $node ) || return;
+ }
+}
+
+sub Progn {
+ my ( $rule, $node ) = @_;
+ my $result;
+ for ( @$rule[ 1 .. $#$rule ] ) {
+ $result = render( $_, $node );
+ }
+ return $result;
+}
+
+sub And {
+ my ( $rule, $node ) = @_;
+ my $result;
+ for ( @$rule[ 1 .. $#$rule ] ) {
+ $result = render( $_, $node ) or return;
+ }
+ return $result;
+}
+
+sub Or {
+ my ( $rule, $node ) = @_;
+ my $result;
+ for ( @$rule[ 1 .. $#$rule ] ) {
+ $result = render( $_, $node ) and return $result;
+ }
+ return;
+}
+
+sub Ref {
+ my ( $rule, $node ) = @_;
+ return if ref($node) ne $rule->[1];
+ return 1 if !$rule->[2];
+ return render( $rule->[2], $node );
+}
+
+sub Lookup {
+ my ( $rule, $node ) = @_;
+ return
+ if !ref($node)
+ || ref($node) eq 'ARRAY'
+ || !exists( $node->{ $rule->[1] } );
+ return 1 if !$rule->[2];
+ return render( $rule->[2], $node->{ $rule->[1] } );
+}
+
+sub Index {
+ my ( $rule, $node ) = @_;
+ return
+ if !ref($node)
+ || ref($node) ne 'ARRAY'
+ || !exists( $node->[ $rule->[1] ] );
+ return 1 if !$rule->[2];
+ return render( $rule->[2], $node->[ $rule->[1] ] );
+}
+
+sub Value {
+ my ( $rule, $node ) = @_;
+ return if ref($node) || $node ne $rule->[1];
+ return 1 if !$rule->[2];
+ return render( $rule->[2], $node );
+}
+
+1;
+

0 comments on commit bd84de4

Please sign in to comment.