Skip to content

Commit bd84de4

Browse files
fglockfglock
committed
Perlito - perl6 - tree grammar modules
1 parent 48991b3 commit bd84de4

File tree

3 files changed

+257
-178
lines changed

3 files changed

+257
-178
lines changed

‎misc/tree_grammar.pl

Lines changed: 40 additions & 178 deletions
Original file line numberDiff line numberDiff line change
@@ -1,56 +1,46 @@
11
package main {
22
use Data::Dumper;
33
use strict;
4+
use Perlito5::TreeGrammar;
45

56
my $in = eval join( '', <> );
67
print Dumper $in;
78

89
my ( $rule, $result );
910

1011
$rule = TreeGrammar::AST::is_sub(
11-
[
12-
Action => sub {
12+
[ Action => sub {
1313
my $sub = $_[0];
1414
my $stmts;
1515
my $var;
16-
TreeGrammar::render(
17-
[
18-
Lookup => 'block',
19-
[
20-
Progn => [ Action => sub { $stmts = $_[0] } ],
21-
[
22-
Star => [
23-
Index => 0,
24-
TreeGrammar::AST::operator_eq(
25-
'infix:<=>',
26-
[
27-
Lookup => 'arguments',
28-
[
29-
And => [
30-
Index => 0,
31-
TreeGrammar::AST::my_var(
32-
[
33-
Action => sub {
34-
$var = $_[0]->{var};
35-
}
36-
]
37-
)
38-
],
39-
[
40-
Index => 1,
41-
TreeGrammar::AST::shift_arg()
42-
],
43-
[
44-
Action => sub {
45-
push @{ $sub->{args} }, $var;
46-
shift @$stmts;
47-
}
48-
]
49-
]
50-
]
51-
)
52-
]
53-
]
16+
Perlito5::TreeGrammar::render(
17+
[ Lookup => 'block',
18+
[ Progn => [ Action => sub { $stmts = $_[0] } ],
19+
[ Star => [
20+
Index => 0,
21+
TreeGrammar::AST::operator_eq( 'infix:<=>',
22+
[ Lookup => 'arguments',
23+
[ And => [ Index => 0,
24+
TreeGrammar::AST::my_var(
25+
[ Action => sub {
26+
$var = $_[0]->{var};
27+
}
28+
]
29+
)
30+
],
31+
[ Index => 1,
32+
TreeGrammar::AST::shift_arg()
33+
],
34+
[ Action => sub {
35+
push @{ $sub->{args} }, $var;
36+
shift @$stmts;
37+
}
38+
]
39+
]
40+
]
41+
)
42+
]
43+
]
5444
]
5545
],
5646
$sub
@@ -59,7 +49,7 @@ package main {
5949
]
6050
);
6151

62-
$result = TreeGrammar::scan( $rule, $in );
52+
$result = Perlito5::TreeGrammar::scan( $rule, $in );
6353
print "result $result\n";
6454
print Dumper $in;
6555

@@ -69,48 +59,39 @@ package TreeGrammar::AST {
6959
use strict;
7060

7161
sub is_sub {
72-
[
73-
Ref => 'Perlito5::AST::Sub',
62+
[ Ref => 'Perlito5::AST::Sub',
7463
( @_ ? [ Progn => @_ ] : () )
7564
];
7665
}
7766

7867
sub named_sub {
79-
[
80-
Ref => 'Perlito5::AST::Sub',
81-
[
82-
And => [ Lookup => 'name', [ Not => [ Value => '' ] ] ],
68+
[ Ref => 'Perlito5::AST::Sub',
69+
[ And => [ Lookup => 'name', [ Not => [ Value => '' ] ] ],
8370
( @_ ? [ Progn => @_ ] : () )
8471
]
8572
];
8673
}
8774

8875
sub operator_eq {
8976
my $name = shift;
90-
[
91-
Ref => 'Perlito5::AST::Apply',
92-
[
93-
And => [ Lookup => 'code', [ Value => $name ] ],
77+
[ Ref => 'Perlito5::AST::Apply',
78+
[ And => [ Lookup => 'code', [ Value => $name ] ],
9479
( @_ ? [ Progn => @_ ] : () )
9580
]
9681
];
9782
}
9883

9984
sub my_var {
100-
[
101-
Ref => 'Perlito5::AST::Decl',
102-
[
103-
And => [ Lookup => 'decl', [ Value => 'my' ] ],
85+
[ Ref => 'Perlito5::AST::Decl',
86+
[ And => [ Lookup => 'decl', [ Value => 'my' ] ],
10487
( @_ ? [ Progn => @_ ] : () )
10588
]
10689
];
10790
}
10891

10992
sub shift_arg {
110-
[
111-
Ref => 'Perlito5::AST::Apply',
112-
[
113-
And => [ Lookup => 'code', [ Value => 'shift' ] ],
93+
[ Ref => 'Perlito5::AST::Apply',
94+
[ And => [ Lookup => 'code', [ Value => 'shift' ] ],
11495

11596
# TODO - bareword => 1, arguments => [], namespace => ''
11697
# or arguments => [ @_ ]
@@ -121,123 +102,4 @@ package TreeGrammar::AST {
121102

122103
}
123104

124-
package TreeGrammar {
125-
use Data::Dumper;
126-
use strict;
127-
128-
my %dispatch;
129-
INIT {
130-
%dispatch = (
131-
Ref => \&Ref, # Ref => 'Perlito5::AST::Apply'
132-
Lookup => \&Lookup, # Lookup => 'namespace'
133-
Index => \&Index, # Index => '0'
134-
Value => \&Value, # Value => '123'
135-
And => \&And,
136-
Or => \&Or,
137-
Not => \&Not,
138-
Action => \&Action,
139-
Progn => \&Progn, # same as in Lisp
140-
Star => \&Star, # same as in regex
141-
);
142-
}
143-
144-
sub render {
145-
my ( $rule, $node ) = @_;
146-
return $dispatch{ $rule->[0] }->( $rule, $node );
147-
}
148-
149-
sub scan {
150-
my ( $rule, $node ) = @_;
151-
render( $rule, $node ) if $rule;
152-
if ( ref($node) eq 'ARRAY' ) {
153-
scan( $rule, $_ ) for @$node;
154-
}
155-
elsif ( ref($node) ) {
156-
scan( $rule, $_ ) for values %$node;
157-
}
158-
return;
159-
}
160105

161-
sub Action {
162-
my ( $rule, $node ) = @_;
163-
$rule->[1]->($node);
164-
return 1;
165-
}
166-
167-
sub Not {
168-
my ( $rule, $node ) = @_;
169-
my $result;
170-
render( $rule->[1], $node ) && return;
171-
return 1;
172-
}
173-
174-
sub Star {
175-
my ( $rule, $node ) = @_;
176-
my $result;
177-
while (1) {
178-
render( $rule->[1], $node ) || return;
179-
}
180-
}
181-
182-
sub Progn {
183-
my ( $rule, $node ) = @_;
184-
my $result;
185-
for ( @$rule[ 1 .. $#$rule ] ) {
186-
$result = render( $_, $node );
187-
}
188-
return $result;
189-
}
190-
191-
sub And {
192-
my ( $rule, $node ) = @_;
193-
my $result;
194-
for ( @$rule[ 1 .. $#$rule ] ) {
195-
$result = render( $_, $node ) or return;
196-
}
197-
return $result;
198-
}
199-
200-
sub Or {
201-
my ( $rule, $node ) = @_;
202-
my $result;
203-
for ( @$rule[ 1 .. $#$rule ] ) {
204-
$result = render( $_, $node ) and return $result;
205-
}
206-
return;
207-
}
208-
209-
sub Ref {
210-
my ( $rule, $node ) = @_;
211-
return if ref($node) ne $rule->[1];
212-
return 1 if !$rule->[2];
213-
return render( $rule->[2], $node );
214-
}
215-
216-
sub Lookup {
217-
my ( $rule, $node ) = @_;
218-
return
219-
if !ref($node)
220-
|| ref($node) eq 'ARRAY'
221-
|| !exists( $node->{ $rule->[1] } );
222-
return 1 if !$rule->[2];
223-
return render( $rule->[2], $node->{ $rule->[1] } );
224-
}
225-
226-
sub Index {
227-
my ( $rule, $node ) = @_;
228-
return
229-
if !ref($node)
230-
|| ref($node) ne 'ARRAY'
231-
|| !exists( $node->[ $rule->[1] ] );
232-
return 1 if !$rule->[2];
233-
return render( $rule->[2], $node->[ $rule->[1] ] );
234-
}
235-
236-
sub Value {
237-
my ( $rule, $node ) = @_;
238-
return if ref($node) || $node ne $rule->[1];
239-
return 1 if !$rule->[2];
240-
return render( $rule->[2], $node );
241-
}
242-
243-
}

‎src5/lib/Perlito5/Perl6/TreeGrammar.pm

Lines changed: 99 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,99 @@
1+
package Perlito5::Perl6::TreeGrammar;
2+
use Data::Dumper;
3+
use strict;
4+
use Perlito5::TreeGrammar;
5+
6+
sub refactor_sub_arguments {
7+
my ($class, $in) = @_;
8+
my ( $rule, $result );
9+
10+
$rule = Perlito5::Perl6::TreeGrammar::is_sub(
11+
[ Action => sub {
12+
my $sub = $_[0];
13+
my $stmts;
14+
my $var;
15+
Perlito5::TreeGrammar::render(
16+
[ Lookup => 'block',
17+
[ Progn => [ Action => sub { $stmts = $_[0] } ],
18+
[ Star => [
19+
Index => 0,
20+
Perlito5::Perl6::TreeGrammar::operator_eq( 'infix:<=>',
21+
[ Lookup => 'arguments',
22+
[ And => [ Index => 0,
23+
Perlito5::Perl6::TreeGrammar::my_var(
24+
[ Action => sub {
25+
$var = $_[0]->{var};
26+
}
27+
]
28+
)
29+
],
30+
[ Index => 1,
31+
Perlito5::Perl6::TreeGrammar::shift_arg()
32+
],
33+
[ Action => sub {
34+
push @{ $sub->{args} }, $var;
35+
shift @$stmts;
36+
}
37+
]
38+
]
39+
]
40+
)
41+
]
42+
]
43+
]
44+
],
45+
$sub
46+
);
47+
}
48+
]
49+
);
50+
51+
$result = Perlito5::TreeGrammar::scan( $rule, $in );
52+
# print "result $result\n";
53+
# print Dumper $in;
54+
}
55+
56+
sub is_sub {
57+
[ Ref => 'Perlito5::AST::Sub',
58+
( @_ ? [ Progn => @_ ] : () )
59+
];
60+
}
61+
62+
sub named_sub {
63+
[ Ref => 'Perlito5::AST::Sub',
64+
[ And => [ Lookup => 'name', [ Not => [ Value => '' ] ] ],
65+
( @_ ? [ Progn => @_ ] : () )
66+
]
67+
];
68+
}
69+
70+
sub operator_eq {
71+
my $name = shift;
72+
[ Ref => 'Perlito5::AST::Apply',
73+
[ And => [ Lookup => 'code', [ Value => $name ] ],
74+
( @_ ? [ Progn => @_ ] : () )
75+
]
76+
];
77+
}
78+
79+
sub my_var {
80+
[ Ref => 'Perlito5::AST::Decl',
81+
[ And => [ Lookup => 'decl', [ Value => 'my' ] ],
82+
( @_ ? [ Progn => @_ ] : () )
83+
]
84+
];
85+
}
86+
87+
sub shift_arg {
88+
[ Ref => 'Perlito5::AST::Apply',
89+
[ And => [ Lookup => 'code', [ Value => 'shift' ] ],
90+
91+
# TODO - bareword => 1, arguments => [], namespace => ''
92+
# or arguments => [ @_ ]
93+
( @_ ? [ Progn => @_ ] : () )
94+
]
95+
];
96+
}
97+
98+
1;
99+

0 commit comments

Comments
 (0)