The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl -w
# This test shows that using the method Parse::Eyapp::Node::delete we can achieve 
# the node self destruction even if its'nt a node!
# Furthermore we use treeregexp

use strict;
use Test::More tests => 3;
use_ok qw( Parse::Eyapp );
#use Parse::Eyapp;
use_ok qw( Parse::Eyapp::Treeregexp );
#use Parse::Eyapp::Treeregexp;
# use Data::Dumper;

my $debug = 0;
my $translationscheme = q{
%{
# head code is available at tree construction time 
# #use Data::Dumper;
%}

%defaultaction  { $lhs->{n} = $_[1]->{n} }
%metatree

%left   '-' '+'
%left   '*' 
%left   NEG

%%
line:       %name EXP  
              exp  
;

exp:    
            %name PLUS  
              exp.left '+'  exp.right 
	        { $lhs->{n} .= $left->{n} + $right->{n} }
        |   %name TIMES 
              exp.left '*' exp.right  
	        { $lhs->{n} = $left->{n} * $right->{n} }
        |   %name NUM   $NUM          
	        { $lhs->{n} = $NUM->{attr} }
        |   '(' $exp ')'  %begin { $exp }       
        |   %name MINUS
	      exp.left '-' exp.right    
	        { $lhs->{n} = $left->{n} - $right->{n} }

        |   %name UMINUS 
	      '-' $exp %prec NEG        
	        { $lhs->{n} = -$exp->{n} }
;

%%
# tail code is available at tree construction time 
sub _Error { die "Syntax error.\n"; }

sub _Lexer {
    my($parser)=shift;

    $parser->YYData->{INPUT} 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/^(.)// and return($1,$1);
        s/^\s*//;
    }
}

sub Run {
    my($self)=shift;
    return $self->YYParse( yylex => \&_Lexer, yyerror => \&_Error );
}
}; # end translation scheme

sub show_match {
  my $self = shift;

  print "Index: $_[1]\n";
#   print "node:\n",Dumper($self);
#   print "Father:\n",Dumper($_[0]);
}

my $transform = Parse::Eyapp::Treeregexp->new( STRING => q{

  delete_code : CODE => { $delete_code->delete() }

  {
    sub not_semantic {
      my $self = shift;
      return  1 if ((ref($self) eq 'TERMINAL') and ($self->{token} eq $self->{attr}));
      return 0;
    }
  }

  delete_tokens : TERMINAL and { not_semantic($TERMINAL) } => { 
    $delete_tokens->delete();
  }
  insert_child : NUM(TERMINAL) => {
    my $b = Parse::Eyapp::Node->new( 'NUM(TERMINAL)', 
			       sub { $_[1]->{attr} = 4+$TERMINAL->{attr} });

    $insert_child->unshift($b);
  }
},
#OUTPUTFILE => 'main.pm'
)->generate();

Parse::Eyapp->new_grammar(
  input=>$translationscheme,
  classname=>'Calc', 
  firstline =>7,
  #outputfile => 'Calc.pm'
); 
my $parser = Calc->new();                # Create the parser

$parser->YYData->{INPUT} = "2*3\n";  # Set the input
my $t = $parser->Run;                # Parse it

# $Data::Dumper::Indent = 1;
# $Data::Dumper::Terse = 1;
# $Data::Dumper::Deepcopy  = 1;
# print Dumper($t);                        # Show the tree

# Get the AST
our ($delete_tokens, $delete_code);
$t->s($delete_tokens, $delete_code);

our $insert_child;
$insert_child->s($t);
# print Dumper($t);                        # Show the tree
my $expectedtree = bless( {
  'children' => [
    bless( {
      'children' => [
        bless( {
          'children' => [ bless( { 'children' => [], 'attr' => 7 }, 'TERMINAL' ) ]
        }, 'NUM' ),
        bless( {
          'children' => [ bless( { 'children' => [], 'attr' => 6 }, 'TERMINAL' ) ] }, 'NUM' ),
        bless( {
          'children' => [ bless( { 'children' => [], 'attr' => 2, 'token' => 'NUM' }, 'TERMINAL' ) ]
        }, 'NUM' ),
        bless( {
          'children' => [ bless( { 'children' => [], 'attr' => 3, 'token' => 'NUM' }, 'TERMINAL' ) ]
        }, 'NUM' )
      ]
    }, 'TIMES' )
  ]
}, 'EXP' );
is_deeply($t, $expectedtree, "unshifting two nodes in myself");