package Pugs::Grammar::Precedence;

# Documentation in the __END__
use 5.006;
use strict;
use warnings;

use Parse::Yapp;

my %relative_precedences = (
    tighter => sub {
        splice( @{$_[0]->{levels}}, $_[1], 0, [ $_[2] ] );
    },
    looser  => sub {
        splice( @{$_[0]->{levels}}, $_[1]+1, 0, [ $_[2] ] );
    },
    equal   => sub {    
        push @{$_[0]->{levels}[$_[1]]}, $_[2];
    },
);

# note: S06 - 'chain' can't be mixed with other types in the same level
my %rule_templates = (
    prefix_non =>        
        "'name' exp         \n" .
        "\t{ \$_[0]->{out}= {fixity => 'prefix', op1 => \$_[1], exp1 => \$_[2],} }", 
    circumfix_non =>     
        "'name' exp 'name2' \n" .
        "\t{ \$_[0]->{out}= {fixity => 'circumfix', op1 => \$_[1], op2 => \$_[3], exp1 => \$_[2],} }\n" .  
        "\t | 'name' 'name2' \n" .
        "\t{ \$_[0]->{out}= {fixity => 'circumfix', op1 => \$_[1], op2 => \$_[2] } }",  
    infix_right =>       
        "exp 'name' exp     \n" .
        "\t{ \$_[0]->{out}= {fixity => 'infix', op1 => \$_[2], exp1 => \$_[1], exp2 => \$_[3],} }",
    postfix_non =>       
        "exp 'name'         \n" .
        "\t{ \$_[0]->{out}= {fixity => 'postfix', op1 => \$_[2], exp1 => \$_[1],} }", 
    postcircumfix_non => 
        "exp 'name' exp 'name2' \n" .
        "\t{ \$_[0]->{out}= {fixity => 'postcircumfix', op1 => \$_[2], op2 => \$_[4], exp1 => \$_[1], exp2 => \$_[3],} } \n" . 
        "\t | exp 'name' 'name2' \n" .
        "\t{ \$_[0]->{out}= {fixity => 'postcircumfix', op1 => \$_[2], op2 => \$_[3], exp1 => \$_[1], } }", 
    infix_left =>        
        "exp 'name' exp     \n" .
        "\t{ \$_[0]->{out}= {fixity => 'infix', op1 => \$_[2], exp1 => \$_[1], exp2 => \$_[3],} }", 
    infix_non =>         
        "exp 'name' exp     \n" .
        "\t{ \$_[0]->{out}= {fixity => 'infix', op1 => \$_[2], exp1 => \$_[1], exp2 => \$_[3],} }", 
    ternary_non =>       
        "exp 'name' exp 'name2' exp \n" .
        "\t{ \$_[0]->{out}= {fixity => 'ternary', op1 => \$_[2], op2 => \$_[4], exp1 => \$_[1], exp2 => \$_[3], exp3 => \$_[5],} }",
        
    # XXX
    #infix_chain =>       
    #    "exp 'name' list_right  \n" .
    #    "\t{ \$_[0]->{out}= {op1 => 'name', exp1 => \$_[1], exp2 => \$_[3],} }",
    #infix_list =>        
    #    "exp 'name' list_right \n" .
    #    "\t{ \$_[0]->{out}= {op1 => 'name', exp1 => \$_[1], exp2 => \$_[3],} }", 
);

sub new {
    my $class = shift;
    my $self = { levels => [], @_ };
    bless $self, $class; 
}

our $op_count = '000';
sub add_op {
    my ($self, $opt) = @_;
    #print "adding $opt->{name}\n";
    $opt->{assoc}  = 'non'    unless defined $opt->{assoc};
    $opt->{fixity} = 'prefix' unless defined $opt->{fixity};
    $opt->{index}  = 'OP' . $op_count++;
    #my $fixity = $opt->{fixity};
    #$fixity .= '_' . $opt->{assoc} if $opt->{fixity} eq 'infix';
    for my $level ( 0 .. $#{$self->{levels}} ) {
        if ( grep { 
                defined $opt->{other} 
                ? ($_->{name} eq $opt->{other}) 
                : 0 
             } @{$self->{levels}[$level]} ) {
            #print "pos $level at $opt->{precedence} $opt->{other}\n";
            $relative_precedences{$opt->{precedence}}->($self, $level, $opt);
            return;
        }
    }
    if ( ! defined $opt->{precedence} ) {
        push @{$self->{levels}}, [ $opt ];
        return;
    }
    die "there is no precedence like ", $opt->{other};
}


sub add_to_list {
    my ( $op, $x, $y ) = @_;
    my @x = ($x);
    @x = @{$x->{list}} if exists $x->{list} && $x->{op1} eq $op;
    return { op1 => $op, list => [ @x, $y ], assoc => 'list' };
}

sub emit_yapp {
    my ($self) = @_;
    my $s;  # = "%{ my \$_[0]->{out}; %}\n";
    my $prec = "P000";
    my %seen;
    for my $level ( reverse 0 .. $#{$self->{levels}} ) {            
        my %assoc;
        for ( @{$self->{levels}[$level]} ) {
            push @{$assoc{ $_->{assoc} }}, $_;
        }
        for ( keys %assoc ) {
            if ( @{$assoc{$_}} ) {
                my $a = $_;
                $a = 'nonassoc' if $a eq 'non';
                $a = 'left'     if $a eq 'list';
                $s .= "%$a ";
                for ( @{ $assoc{$_} } ) {
                    next if $seen{$_->{name}};
                    $seen{$_->{name}} = 1;
                    $s .= ' ' .
                        $_ eq 'list' 
                            ? $_->{index}
                            : "'$_->{name}'";
                }
                $s .= 
                    " $prec" .
                    "\n";
                # $seen{$_->{name}} = 1 for @{$assoc{$_}};
                $prec++;
            }
        }
    }
    $s .= "%%\n" .
        "statement:  exp { return(\$_[0]->{out}) } ;\n";
            
    if ( defined $self->{header} ) {
        $s .= $self->{header};
    }
    else {
        $s .=     
            "exp:   NUM  { \$_[0]->{out}= \$_[1] }\n";
    }
    $prec = "P000";
    for my $level ( reverse 0 .. $#{$self->{levels}} ) {            
        my %assoc;
        for ( @{$self->{levels}[$level]} ) {
            push @{$assoc{ $_->{assoc} }}, $_;
        }
        for ( keys %assoc ) {
            if ( @{$assoc{$_}} ) {


                for my $op ( @{$assoc{$_}} ) {
                    if ( $op->{assoc} eq 'list' ) {
                        $s .= 
                            "    |  exp '$op->{name}' exp   %prec $prec\n" .
                            "        { \$_[0]->{out}= Pugs::Grammar::Precedence::add_to_list( '$op->{name}', \$_[1], \$_[3] ) } \n" ;
                        $s .= 
                            "    |  exp '$op->{name}'    %prec $prec\n" .
                            "        { \$_[0]->{out}= \$_[1] } \n" ;
                        next;
                    }
                    my $t = $rule_templates{"$op->{fixity}_$op->{assoc}"};
                    unless ( defined $t ) {
                        warn "can't find template for '$op->{fixity}_$op->{assoc}'";
                        next;
                    }
                    $t =~ s/$_/$op->{$_}/g for qw( name2 name );
                    $t =~ s/\{ /%prec $prec { /;
                    $s .= "    |  $t \n" . 
                        # "\t%prec $prec\n" .
                        "\t/* $op->{name} $op->{fixity} $op->{assoc} */\n";
                }
                $prec++;
            }
        }
    }
    $s .= ";\n" .
        "%%\n";
    #print $s;
    return $s;
}

sub emit_grammar_perl5 {
    my $self = shift;
    my $g = $self->emit_yapp();
    #print $g;
    my $p = Parse::Yapp->new( input => $g );
    return $p->Output( classname => $self->{grammar} );
}

sub exists_op { die "not implemented" };
sub delete_op { die "not implemented" };
sub get_op    { die "not implemented" };
sub inherit_category { die "not implemented" };
sub inherit_grammar  { die "not implemented" };
sub merge_category   { die "not implemented" };
sub code  { die "not implemented" }
sub match { die "not implemented" }
sub perl5 { die "not implemented" }

1;

__END__

=head1 NAME 

Pugs::Grammar::Precedence - Engine for Perl 6 Rule operator precedence

=head1 SYNOPSIS

  use Pugs::Grammar::Precedence;

  # example definition for "sub rxinfix:<|> ..."
  
  my $rxinfix = Pugs::Grammar::Precedence->new( 
    grammar => 'rxinfix',
  );
  $rxinfix->add_op( 
    name => '|',
    assoc => 'left',
    fixity => 'infix',
  );

Pseudo-code for usage inside a grammar:

    sub new_proto( $match ) {
        return ${$match<category>}.add_op( 
            name => $match<name>, 
            fixity => ..., 
            precedence => ...,
        );
    }

    rule prototype {
        proto <category>:<name> <options>
        { 
            return new_proto($/);
        }
    }

    rule statement {
        <category.parse> ...
    }

=head1 DESCRIPTION

This module provides an implementation for Perl 6 operator precedence.  

=head1 METHODS

=head2 new ()

Class method.  Returns a category object.

options:

=item * grammar => $category_name - the name of this category 
(a namespace or a Grammar name).

=head2 add_op ()

Instance method.  Adds a new operator to the category.

options:

=item * name => $operator_name - the name of this operator, such as '+', '*'

=item * name2 => $operator_name - the name of the second operator in
an operator pair, such as circumfix [ '(', ')' ] or ternary [ '??', '!!' ]. 

 # precedence=>'tighter', 
 #   tighter/looser/equiv 
 # other=>'+', 
 # fixity => 
 #  infix/prefix/circumfix/postcircumfix/ternary
 # assoc =>
 #  left/right/non/chain/list
 # rule=>$rule 
 #  (is parsed) 

=head1 AUTHORS

The Pugs Team E<lt>perl6-compiler@perl.orgE<gt>.

=head1 SEE ALSO

Summary of Perl 6 Operators: L<http://dev.perl.org/perl6/doc/design/syn/S03.html>

=head1 COPYRIGHT

Copyright 2006 by Flavio Soibelmann Glock and others.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

See L<http://www.perl.com/perl/misc/Artistic.html>

=cut