The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl -w
use strict;
use Test::More tests=>8;
use_ok qw(Parse::Eyapp) or exit;

use Data::Dumper;

my $grammar = q{

  %right  '='
  %left   '-' '+'
  %left   '*' '/'
  %left   NEG
  %tree bypass alias

  %%
  line: $exp  { $_[1] } 
  ;

  exp:      
      %name NUM   
            $NUM 
    | %name VAR  
            $VAR 
    | %name ASSIGN        
            $VAR '=' $exp 
    | %name PLUS 
            exp.left '+' exp.right 
    | %name MINUS       
            exp.left '-' exp.right 
    | %name TIMES   
            exp.left '*' exp.right 
    | %name DIV     
            exp.left '/' exp.right 
    | %no bypass UMINUS
            '-' $exp %prec NEG 
    |   '(' exp ')'  { $_[2] } /* Let us simplify a bit the tree */
  ;

  %%

  sub _Error {
          exists $_[0]->YYData->{ERRMSG}
      and do {
          print $_[0]->YYData->{ERRMSG};
          delete $_[0]->YYData->{ERRMSG};
          return;
      };
      print "Syntax error.\n";
  }

  sub _Lexer {
      my($parser)=shift;

          $parser->YYData->{INPUT}
      or  $parser->YYData->{INPUT} = <STDIN>
      or  return('',undef);

      $parser->YYData->{INPUT}=~s/^\s+//;

      for ($parser->YYData->{INPUT}) {
          s/^([0-9]+(?:\.[0-9]+)?)//
                  and return('NUM',$1);
          s/^([A-Za-z][A-Za-z0-9_]*)//
                  and return('VAR',$1);
          s/^(.)//s
                  and return($1,$1);
      }
  }

  sub Run {
      my($self)=shift;
      $self->YYParse( yylex => \&_Lexer, yyerror => \&_Error, 
          #yydebug =>0xFF
        );
  }
}; # end grammar


Parse::Eyapp->new_grammar(
  input=>$grammar, 
  classname=>'Alias', 
  #firstline =>7,
  outputfile => 'main',
);

my $parser = Alias->new( yyprefix => 'R::S::');
$parser->YYData->{INPUT} = "a = -(2*3+5-1)\n";
my $t = $parser->Run;
can_ok('R::S::ASSIGN', 'VAR', 'exp');
can_ok('R::S::PLUS', 'left', 'right');
can_ok('R::S::MINUS', 'left', 'right');
can_ok('R::S::TIMES', 'left', 'right');
can_ok('R::S::DIV', 'left', 'right');


is($t->VAR->attr, 'a', 'alias accessor ok');
# $t is 
# R::S::ASSIGN(
#   R::S::TERMINAL,
#   R::S::UMINUS(
#      R::S::MINUS(
#         R::S::PLUS(R::S::TIMES(R::S::NUM,R::S::NUM),R::S::NUM),
#         R::S::NUM)))   

my $expected = bless( {
                 'children' => [
                                 bless( {
                                          'children' => [
                                                          bless( {
                                                                   'children' => [],
                                                                   'attr' => '2',
                                                                   'token' => 'NUM'
                                                                 }, 'R::S::NUM' ),
                                                          bless( {
                                                                   'children' => [],
                                                                   'attr' => '3',
                                                                   'token' => 'NUM'
                                                                 }, 'R::S::NUM' )
                                                        ]
                                        }, 'R::S::TIMES' ),
                                 bless( {
                                          'children' => [],
                                          'attr' => '5',
                                          'token' => 'NUM'
                                        }, 'R::S::NUM' )
                               ]
               }, 'R::S::PLUS' );

is_deeply($t->exp->exp->left, $expected, 'alias accessor ok');
#print $t->exp->exp->right->str."\n"; # 1