1package Pugs::Grammar::Precedence;
2
3# Documentation in the __END__
4use 5.006;
5use strict;
6use warnings;
7
8use Parse::Yapp;
9use Digest::MD5 'md5_hex';
10
11my $cache;
12eval {
13    require Cache::FileCache;
14    $cache = new Cache::FileCache( { 'namespace' => 'v6-precedence' } );
15};
16
17my %relative_precedences = (
18    tighter => sub {
19        splice( @{$_[0]->{levels}}, $_[1], 0, [ $_[2] ] );
20    },
21    looser  => sub {
22        splice( @{$_[0]->{levels}}, $_[1]+1, 0, [ $_[2] ] );
23    },
24    equal   => sub {
25        push @{$_[0]->{levels}[$_[1]]}, $_[2];
26    },
27);
28
29# note: S06 - 'chain' can't be mixed with other types in the same level
30my %rule_templates = (
31    prefix_non =>
32        "'name' exp         \n" .
33        "\t{ \$_[0]->{out}= {fixity => 'prefix', op1 => \$_[1], exp1 => \$_[2],} }",
34    circumfix_non =>
35        "'name' exp 'name2' \n" .
36        "\t{ \$_[0]->{out}= {fixity => 'circumfix', op1 => \$_[1], op2 => \$_[3], exp1 => \$_[2],} }\n" .
37        "\t | 'name' 'name2' \n" .
38        "\t{ \$_[0]->{out}= {fixity => 'circumfix', op1 => \$_[1], op2 => \$_[2] } }",
39    infix_right =>
40        "exp 'name' exp     \n" .
41        "\t{ \$_[0]->{out}= {fixity => 'infix', op1 => \$_[2], exp1 => \$_[1], exp2 => \$_[3],} }",
42    postfix_non =>
43        "exp 'name'         \n" .
44        "\t{ \$_[0]->{out}= {fixity => 'postfix', op1 => \$_[2], exp1 => \$_[1],} }",
45    postcircumfix_non =>
46        "exp 'name' exp 'name2' \n" .
47        "\t{ \$_[0]->{out}= {fixity => 'postcircumfix', op1 => \$_[2], op2 => \$_[4], exp1 => \$_[1], exp2 => \$_[3],} } \n" .
48        "\t | exp 'name' 'name2' \n" .
49        "\t{ \$_[0]->{out}= {fixity => 'postcircumfix', op1 => \$_[2], op2 => \$_[3], exp1 => \$_[1], } }",
50    infix_left =>
51        "exp 'name' exp     \n" .
52        "\t{ \$_[0]->{out}= {fixity => 'infix', op1 => \$_[2], exp1 => \$_[1], exp2 => \$_[3],} }",
53    infix_non =>
54        "exp 'name' exp     \n" .
55        "\t{ \$_[0]->{out}= {fixity => 'infix', op1 => \$_[2], exp1 => \$_[1], exp2 => \$_[3],} }",
56    ternary_non =>
57        "exp 'name' exp 'name2' exp \n" .
58        "\t{ \$_[0]->{out}= {fixity => 'ternary', op1 => \$_[2], op2 => \$_[4], exp1 => \$_[1], exp2 => \$_[3], exp3 => \$_[5],} }",
59
60    # XXX
61    #infix_chain =>
62    #    "exp 'name' chain_right  \n" .
63    #    "\t{ \$_[0]->{out}= {op1 => 'name', exp1 => \$_[1], exp2 => \$_[3],} }",
64    #infix_list =>
65    #    "exp 'name' list_right \n" .
66    #    "\t{ \$_[0]->{out}= {op1 => 'name', exp1 => \$_[1], exp2 => \$_[3],} }",
67);
68
69sub new {
70    my $class = shift;
71    my $self = { levels => [], @_ };
72    bless $self, $class;
73}
74
75our $op_count = '000';
76sub add_op {
77    my ($self, $opt) = @_;
78    #print "adding $opt->{name}\n";
79    $opt->{assoc}  = 'non'    unless defined $opt->{assoc};
80    $opt->{fixity} = 'prefix' unless defined $opt->{fixity};
81    $opt->{index}  = 'OP' . $op_count++;
82    #my $fixity = $opt->{fixity};
83    #$fixity .= '_' . $opt->{assoc} if $opt->{fixity} eq 'infix';
84    for my $level ( 0 .. $#{$self->{levels}} ) {
85        if ( grep {
86                defined $opt->{other}
87                ? ($_->{name} eq $opt->{other})
88                : 0
89             } @{$self->{levels}[$level]} ) {
90            #print "pos $level at $opt->{precedence} $opt->{other}\n";
91            $relative_precedences{$opt->{precedence}}->($self, $level, $opt);
92            #print "Precedence table: ", Dump( $self );
93            return;
94        }
95    }
96    if ( ! defined $opt->{precedence} ) {
97        push @{$self->{levels}}, [ $opt ];
98        return;
99    }
100    die "there is no precedence like ", $opt->{other};
101}
102
103
104sub add_to_list {
105    my ( $op, $x, $y ) = @_;
106    my @x = ($x);
107    @x = @{$x->{list}} if exists $x->{list} && $x->{op1} eq $op;
108    return { op1 => $op, list => [ @x, $y ], assoc => 'list' };
109}
110
111sub add_to_chain {
112    my ( $op, $x, $y ) = @_;
113    my @x = exists $x->{chain} ? @{$x->{chain}} : ($x);
114    my @y = exists $y->{chain} ? @{$y->{chain}} : ($y);
115    return { chain => [ @x, $op, @y ], assoc => 'chain' };
116}
117
118sub emit_yapp {
119    my ($self) = @_;
120    my $s;  # = "%{ my \$_[0]->{out}; %}\n";
121    my $prec = "P000";
122    my %seen;
123    for my $level ( reverse 0 .. $#{$self->{levels}} ) {
124        my %assoc;
125        for my $operator ( @{$self->{levels}[$level]} ) {
126            push @{$assoc{ $operator->{assoc} }}, $operator;
127        }
128        for my $aaa ( keys %assoc ) {
129            if ( @{$assoc{$aaa}} ) {
130                my $a = $aaa;
131                $a = 'nonassoc' if $a eq 'non';
132                $a = 'left'     if $a eq 'list';
133                $a = 'left'     if $a eq 'chain';
134                $s .= "%$a ";
135                for my $operator ( @{ $assoc{$aaa} } ) {
136                    next if $seen{$operator->{name}};
137                    $seen{$operator->{name}} = 1;
138                    $s .= ' ' .
139                             "'$operator->{name}'" ;
140                        # (( $aaa eq 'list' || $aaa eq 'chain' )
141                        #     ? $operator->{index}
142                        #     : "'$operator->{name}'"
143                        # );
144                }
145                $s .=
146                    " $prec" .
147                    "\n";
148                # $seen{$_->{name}} = 1 for @{$assoc{$_}};
149                $prec++;
150            }
151        }
152    }
153    $s .= "%%\n" .
154        "statement:  exp { return(\$_[0]->{out}) } ;\n";
155
156    if ( defined $self->{header} ) {
157        $s .= $self->{header};
158    }
159    else {
160        $s .=
161            "exp:   NUM  { \$_[0]->{out}= \$_[1] }\n";
162    }
163    $prec = "P000";
164    for my $level ( reverse 0 .. $#{$self->{levels}} ) {
165        my %assoc;
166        for ( @{$self->{levels}[$level]} ) {
167            push @{$assoc{ $_->{assoc} }}, $_;
168        }
169        for ( keys %assoc ) {
170            if ( @{$assoc{$_}} ) {
171
172
173                for my $op ( @{$assoc{$_}} ) {
174                    if ( $op->{assoc} eq 'list' ) {
175                        $s .=
176                            "    |  exp '$op->{name}' exp   %prec $prec\n" .
177                            "        { \$_[0]->{out}= Pugs::Grammar::Precedence::add_to_list( '$op->{name}', \$_[1], \$_[3] ) } \n" ;
178                        $s .=
179                            "    |  exp '$op->{name}'    %prec $prec\n" .
180                            "        { \$_[0]->{out}= Pugs::Grammar::Precedence::add_to_list( '$op->{name}', \$_[1], { null => 1 } ) } \n" ;
181                            # "        { \$_[0]->{out}= \$_[1] } \n" ;
182                        next;
183                    }
184                    if ( $op->{assoc} eq 'chain' ) {
185                        $s .=
186                            "    |  exp '$op->{name}' exp   %prec $prec\n" .
187                            "        { \$_[0]->{out}= Pugs::Grammar::Precedence::add_to_chain( '$op->{name}', \$_[1], \$_[3] ) } \n" ;
188                        $s .=
189                            "    |  exp '$op->{name}'    %prec $prec\n" .
190                            "        { \$_[0]->{out}= Pugs::Grammar::Precedence::add_to_chain( '$op->{name}', \$_[1], { null => 1 } ) } \n" ;
191                            # "        { \$_[0]->{out}= \$_[1] } \n" ;
192                        next;
193                    }
194                    my $t = $rule_templates{"$op->{fixity}_$op->{assoc}"};
195                    unless ( defined $t ) {
196                        warn "can't find template for '$op->{fixity}_$op->{assoc}'";
197                        next;
198                    }
199                    $t =~ s/$_/$op->{$_}/g for qw( name2 name );
200                    $t =~ s/\{ /%prec $prec { /;
201                    $s .= "    |  $t \n" .
202                        # "\t%prec $prec\n" .
203                        "\t/* $op->{name} $op->{fixity} $op->{assoc} */\n";
204                }
205                $prec++;
206            }
207        }
208    }
209    $s .= ";\n" .
210        "%%\n";
211    #print $s;
212    return $s;
213}
214
215sub emit_grammar_perl5 {
216    my $self = shift;
217    my $g = $self->emit_yapp();
218    #print $g;
219
220    my $digest = md5_hex($self->{grammar} . $g);
221    my $cached;
222
223    if ($cache && ($cached = $cache->get($digest))) {
224	return $cached;
225    }
226
227    my $p = Parse::Yapp->new( input => $g );
228    $cached = $p->Output( classname => $self->{grammar} );
229    $cache->set($digest, $cached) if $cache;
230    return $cached;
231}
232
233sub exists_op { die "not implemented" };
234sub delete_op { die "not implemented" };
235sub get_op    { die "not implemented" };
236sub inherit_category { die "not implemented" };
237sub inherit_grammar  { die "not implemented" };
238sub merge_category   { die "not implemented" };
239sub code  { die "not implemented" }
240sub match { die "not implemented" }
241sub perl5 { die "not implemented" }
242
2431;
244
245__END__
246
247=head1 NAME
248
249Pugs::Grammar::Precedence - Engine for Perl 6 Rule operator precedence
250
251=head1 SYNOPSIS
252
253  use Pugs::Grammar::Precedence;
254
255  # example definition for "sub rxinfix:<|> ..."
256
257  my $rxinfix = Pugs::Grammar::Precedence->new(
258    grammar => 'rxinfix',
259  );
260  $rxinfix->add_op(
261    name => '|',
262    assoc => 'left',
263    fixity => 'infix',
264  );
265
266Pseudo-code for usage inside a grammar:
267
268    sub new_proto( $match ) {
269        return ${$match<category>}.add_op(
270            name => $match<name>,
271            fixity => ...,
272            precedence => ...,
273        );
274    }
275
276    rule prototype {
277        proto <category>:<name> <options>
278        {
279            return new_proto($/);
280        }
281    }
282
283    rule statement {
284        <category.parse> ...
285    }
286
287=head1 DESCRIPTION
288
289This module provides an implementation for Perl 6 operator precedence.
290
291=head1 METHODS
292
293=head2 new ()
294
295Class method.  Returns a category object.
296
297options:
298
299=over
300
301=item * C<< grammar => $category_name >> - the name of this category
302(a namespace or a Grammar name).
303
304=back
305
306=head2 add_op ()
307
308Instance method.  Adds a new operator to the category.
309
310options:
311
312=over
313
314=item * name => $operator_name - the name of this operator, such as '+', '*'
315
316=item * name2 => $operator_name - the name of the second operator in
317an operator pair, such as circumfix [ '(', ')' ] or ternary [ '??', '!!' ].
318
319 # precedence=>'tighter',
320 #   tighter/looser/equiv
321 # other=>'+',
322 # fixity =>
323 #  infix/prefix/circumfix/postcircumfix/ternary
324 # assoc =>
325 #  left/right/non/chain/list
326 # rule=>$rule
327 #  (is parsed)
328
329=back
330
331=head1 AUTHORS
332
333The Pugs Team E<lt>perl6-compiler@perl.orgE<gt>.
334
335=head1 SEE ALSO
336
337Summary of Perl 6 Operators: L<http://dev.perl.org/perl6/doc/design/syn/S03.html>
338
339=head1 COPYRIGHT
340
341Copyright 2006, 2007 by Flavio Soibelmann Glock and others.
342
343This program is free software; you can redistribute it and/or modify it
344under the same terms as Perl itself.
345
346See L<http://www.perl.com/perl/misc/Artistic.html>
347
348=cut
349
350