#~/usr/bin/perl

package P6RulesInP5::OpTable;
use base qw/Class::Accessor/;

use strict;
use warnings;
use constant PGE_OPTABLE_EMPTY => 0;
use constant PGE_OPTABLE_TERM => 1;
use constant PGE_OPTABLE_POSTFIX => 2;
use constant PGE_OPTABLE_CLOSE => 3;
use constant PGE_OPTABLE_PREFIX => 4;
use constant PGE_OPTABLE_INFIX => 5;
use constant PGE_OPTABLE_TERNARY => 6;
use constant PGE_OPTABLE_POSTCIRCUMFIX => 7;
use constant PGE_OPTABLE_CIRCUMFIX => 8;

BEGIN {
  __PACKAGE__->mk_accessors(qw/
    tokenTable 
    termTable 
    operatorTable 
    whitespaceTermTable 
    whitespaceOperatorTable/)
}

sub new {
  my $class = shift;
  my $object = bless {}, $class;
  $object->tokenTable({}) ;
  $object->termTable({});
  $object->operatorTable({});
  $object->whitespaceTermTable({});
  $object->whitespaceOperatorTable({}); 
  $object;
}

sub printHash
{
  my ($hash, $desc) = @_;
  while ( my ($k,$v) = each %$hash ) {
    print "$desc: $k => $v\n";
  }
  if ( not scalar keys %$hash )
  {
    print "$desc: empty\n";
  }
}

sub addToken {
  my ($self, $name, $relativePrecedence, $options, $match) = @_;
  #print "name: $name - rp: $relativePrecedence - options: $options - match: $match\n" ;
  my $equivalence = "=";

  $match = "P6RulesInP5::Match" if ! defined $match; 
  $options = "left" if not $options;
  if ( $relativePrecedence and $relativePrecedence ne "" )
  {
    if ( substr $relativePrecedence, 0, 1 =~ m/[\=\<\>]/ )
    {
      my $tokenTableKey = substr $relativePrecedence, -1, 0;
      $equivalence = $self->tokenTable()->{$tokenTableKey}{equiv};
    }
    else
    {
      $equivalence = $self->tokenTable()->{$relativePrecedence}{equiv};
    }
  }

  my $noWhitespace = 0;
  $noWhitespace = 1 if ((index $options, "nows") >= 0);

  #print "name: $name - eq: $equivalence - rp: $relativePrecedence - options: $options - match: $match\n" ;
  my %token = ( name => $name, options => $options, equiv => $equivalence, match => $match, arity => 1 );
  my @nameSplit = split /:/, $name;
  #print "@nameSplit ", length @nameSplit, " ", $#nameSplit, "\n";
  my @spacePresent = split / /, $nameSplit[$#nameSplit];
  if ( @spacePresent > 1 )
  {
    $token{token2} = $spacePresent[1];
    my %tokenClone = %token;
    $tokenClone{syncat} = PGE_OPTABLE_CLOSE;
    $self->operatorTable()->{$spacePresent[1]} = %tokenClone;
    $self->whitespaceOperatorTable()->{$spacePresent[1]} = %tokenClone;
  }

  $token{token1} = $nameSplit[$#nameSplit];
  $self->tokenTable()->{$name} = \%token;

  my $syncat = $nameSplit[0];
  if ( $syncat eq "infix" )
  {
    $token{syncat} = PGE_OPTABLE_INFIX;
    $token{arity} = 2;
  }
  elsif ( $syncat eq "postfix" )
  {
    $token{syncat} = PGE_OPTABLE_POSTFIX;
  }
  elsif ( $syncat eq "circumfix" )
  {
    $token{syncat} = PGE_OPTABLE_CIRCUMFIX;
  }
  elsif ( $syncat eq "prefix" )
  {
    $token{syncat} = PGE_OPTABLE_PREFIX;
  }
  elsif ( $syncat eq "postcircumfix" )
  {
    $token{syncat} = PGE_OPTABLE_POSTCIRCUMFIX;
    $token{arity} = 2;
  }
  elsif ( $syncat eq "ternary" )
  {
    $token{syncat} = PGE_OPTABLE_TERNARY;
    $token{arity} = 3;
  }
  elsif ( $syncat eq "close" )
  {
    $token{syncat} = PGE_OPTABLE_CLOSE;
    $token{arity} = 0;
  }
  else
  {
    $token{syncat} = PGE_OPTABLE_TERM;
  }
}

sub parse
{
  my ($self, $matchObj) = @_;
  my @termStack = [];
  my @operatorStack = [];
  my @tokenStack = [];
  my $termEmpty = $self->termTable()->{""};
  my $operatorEmpty = $self->operatorTable()->{""};

  ($matchObj, my $target, my $matchObjFrom, my $matchObjPos) = Parser::Rule::Match::newfrom($matchObj, 0);
  my $position = $matchObjPos;
  my $lastPosition = length $target;
  my @bsrStack = [];
  #XXX
  my $operator;
  expect_term:
  goto null_term if $position >= $lastPosition;
 
  my $currentTermTable = $self->whitespaceTermTable();
  (substr $target, $position, $lastPosition) =~ m/[^\s]/;
  my $whitespacePosition = $-[0];
  $currentTermTable = $self->termTable() if ($whitespacePosition <= $position);

  expect_term_1:
  my $key = $$currentTermTable->lkey($target, $whitespacePosition);
  my $token = $$currentTermTable{$key};
  unless ($token)
  {
    push @bsrStack, "bsr_token_match_1";
    goto token_match;
    bsr_token_match_1:
    goto found_term if $operator;
    goto null_term if ($key eq "");
  }
  expect_term_empty:
  if ( $termEmpty )
  {
    $token = $termEmpty;
    $key = "";
    $whitespacePosition = $position;
    push @bsrStack, "bsr_token_match_2";
    goto token_match;
    bsr_token_match_2:
    goto found_term if $operator;
  }
  null_term:
  if (@tokenStack)
  {
    my $top = $tokenStack[-1];
    goto missing_term if ((index $$top["opts"], "nullterm") < 1);
    ($operator, my $stringTemp, my $tempPos, my $tempPos2) = newfrom( $matchObj, $whitespacePosition, "PGE::Match");
    my $temp2 = $whitespacePosition;
    push @termStack, $operator;
    goto expect_operator;
  }
  else
  {
    goto missing_term;
  }
  missing_term:
  push @termStack, newfrom( $matchObj, $whitespacePosition, "PGE::Match" );
  goto end;
  found_term:
  my $tokenCat = $$token{syncat};
  $position = $operator->to();
  goto oper_shift if ( $tokenCat == PGE_OPTABLE_PREFIX );
  goto oper_shift if ( $tokenCat == PGE_OPTABLE_CIRCUMFIX );
  push @termStack, $operator;

  expect_oper:
  goto end if ( $position >= $lastPosition );
  my $currentOperatorTable = $self->whitespaceOperatorTable();
  
  (substr $target, $position, $lastPosition) =~ m/[^\s]/;
  $whitespacePosition = $-[0];
  $currentOperatorTable = $self->operatorTable() if ( $whitespacePosition <= $position );

  expect_oper_1:
  $key = $$currentOperatorTable->lkey($target, $whitespacePosition);
  $token = $$currentOperatorTable{$key};
  if ( $token )
  {
    push @bsrStack, "bsr_token_match2_1";
    goto token_match;
    bsr_token_match2_1:
    goto found_oper if $operator;          
  }

  expect_oper_empty:
  goto end unless $operatorEmpty;
  $token = $operatorEmpty;
  $key = "";
  $whitespacePosition = $position;
  push @bsrStack, "bsr_token_match_3";
  goto token_match;
  bsr_token_match_3:
  goto end unless $operator;

  found_oper:
  $tokenCat = $$token{syncat};

  shift_reduce:
  my $topcat = PGE_OPTABLE_EMPTY;
  if ( @tokenStack <= 0 )
  {
    goto end if $tokenCat == PGE_OPTABLE_CLOSE;
    goto oper_shift;
  }

  shift_reduce_1:
  my $top = $tokenStack[-1];
  $topcat = $$top{syncat};
  goto oper_reduce if ( $topcat == PGE_OPTABLE_POSTFIX );
  goto oper_close if ( $topcat == PGE_OPTABLE_CLOSE );
  goto oper_shift if ( $topcat == PGE_OPTABLE_POSTCIRCUMFIX );
  #$temp1 = $$token{eqiv};
  #$temp2 = $$top{eqiv};
  goto oper_shift if $$token{eqiv} > $$top{eqiv};
  goto shift_reduce_2 if ( $topcat == PGE_OPTABLE_TERNARY );
  goto ternary_error if ( $topcat == PGE_OPTABLE_TERNARY );
  goto oper_shift;

  shift_reduce2:
  #if ( $temp1 >= $temp2 )
  if ( $$token{eqiv} > $$top{eqiv} )
  {
    goto oper_shift if ( (index $$top{opts}, "right" ) >=0 );
  }
  
  oper_reduce:
  push @bsrStack, "bsr_reduce_1";
  goto reduce;
  bsr_reduce_1:
  goto shift_reduce;

  oper_close:
  goto oper_reduce if $topcat < PGE_OPTABLE_TERNARY;
  goto end if $key ne $$top{token2};

  oper_shift:
  push @tokenStack, $token;
  push @operatorStack, $operator;
  $position = $operator->to();
  goto expect_term if ( $tokenCat >= PGE_OPTABLE_PREFIX );
  goto expect_oper if ( $tokenCat >= PGE_OPTABLE_POSTFIX );
  goto expect_term if ( $tokenCat >= PGE_OPTABLE_TERNARY );
  goto expect_oper;

  reduce:
  my $temp1 = pop @tokenStack;
  my $temp2 = $$temp1{syncat};
  if ( $temp2 == PGE_OPTABLE_CLOSE )
  {
    $temp1 = pop @tokenStack;
    $temp2 = pop @operatorStack;
  }
  reduce_1:
  my $arity = $$temp1{arity};
  $temp1 = pop @operatorStack;

  reduce_args:
  goto reduce_saveterm if $arity < 1;
  $temp2 = pop @termStack;
  if ( $temp2 )
  {
    $arity--;
    $$temp1[$arity] = $temp2;
    goto reduce_args;
  }
  reduce_backtrack:
  $position = $temp1->from();
  goto reduce_end if $arity > 1;
  $temp1 = $temp2;
  reduce_save_term:
  push @termStack, $temp1;
  reduce_end:
  goto (pop @bsrStack);

  token_match:
  $matchObjPos = $whitespacePosition;
  my $match = $$token{match};
  #TODO == should be isa
  goto tok_match_sub if ( $match == "Sub" );
  ($operator) = newfrom($matchObj, $whitespacePosition, $match);
  #What does this line 
  #$temp1 = length $key + $whitespacePosition;
  goto tok_match_end;

  tok_match_sub:
  $operator = &$$match($matchObj);
  tok_match_end:
  $$operator{type} = $$token{name};
  goto (pop @bsrStack);

  end:
  if ( @tokenStack >= 1 )
  {
    push @bsrStack, "bsr_reduce_2";
    goto reduce;
    bsr_reduce_2:
    goto end;
  }
  end_1:
  goto end_2 if @termStack < 1;
  $temp1 = pop @termStack;
  goto end_2 unless $temp1;
  $$matchObj{expr} = $temp1;
  $matchObjPos = $position;
  return ( $matchObj );
  end_2:
  $matchObjPos = -1;
  return ( $matchObj );

  ternary_error:
  $matchObjPos = -1;
  die "Missing ternary close at offset $whitespacePosition \n";
  return ( $matchObj );

}

__PACKAGE__;