Parse -> Rewrite tree -> Serialize

RR.pm

package RR;
use strict;
use Marpa::R2 2.042000;
use Data::Dumper;

use base 'Exporter';
our @EXPORT_OK = qw/replace/;

sub new {
    my ($class) = @_;

    my $self = bless {}, $class;

    $self->{grammar} = Marpa::R2::Scanless::G->new(
        {
            action_object  => 'RR::Actions',
            default_action => 'do_first_arg',
            source         => \(<<'END_OF_SOURCE'),

:start         ::= script

script         ::= expression
                 | script ';' expression             action => do_arg02

expression     ::= number                            action => do_num
                 | variable                          action => do_var
                 | tree_var                          action => do_tree_var
                 | '(' expression ')'                assoc => group action => do_arg1
                 | expression '(' args ')'           action => do_func
                || expression '*' expression         action => do_expr
                 | expression '/' expression         action => do_expr
                || expression '+' expression         action => do_expr
                 | expression '-' expression         action => do_expr

args           ::= expression*                       action => do_list separator => comma 

comma          ~ ','
number         ~ [\d]+
tree_var       ~ ':' tree_var_1
variable       ~ [a-z]+
tree_var_1     ~ [a-z]+

:discard       ~ whitespace
whitespace     ~ [\s]+
END_OF_SOURCE

        }
    );
    return $self;
}

sub parse {
    my ($self, $string) = @_;
    my $re = Marpa::R2::Scanless::R->new( { grammar => $self->{grammar} } );
    $re->read(\$string);
    my $value_ref = $re->value();
    return ${$value_ref};
}

sub parse_rr {
    my ($string) = @_;
    my $parser = RR->new();
    return $parser->parse($string);
}

sub _expr_match {
    my ($a, $b, $matches) = @_;

    if ($a->[0] eq $b->[0]) {
        if ($a->[0] eq 'num') {
            return $a->[1] == $b->[1];
        }
        elsif ($a->[0] eq 'var') {
            return $a->[1] eq $b->[1];
        }
        elsif ($a->[0] eq 'func') {
            if (!_expr_match($a->[1], $b->[1], $matches)) {
                return;
            }
            for (0 .. (scalar(@{$a->[2]})-1)) {
                if (!_expr_match($a->[2][$_], $b->[2][$_], $matches)) {
                    return;
                }
            }
            return 1;
        }
        elsif ($a->[0] eq 'op') {
            return $a->[1] eq $b->[1]
            && ((_expr_match($a->[2], $b->[2], $matches) && _expr_match($a->[3], $b->[3], $matches))
                ||
                (_expr_match($a->[2], $b->[3], $matches) && _expr_match($a->[3], $b->[2], $matches)))
        }
    }
    elsif ($a->[0] eq 'tree') {
        $matches->{$a->[1]} = $b;
        return 1;
    }
    elsif ($b->[0] eq 'tree') {
        $matches->{$b->[1]} = $a;
        return 1;
    }
    return;
}

sub _replace_matches {
    my ($matches, $tree) = @_;
    for (keys %$matches) {
        $tree = _replace_helper($tree, ['tvar', $_ ], $matches->{$_}, $matches);
    }
    return $tree;
}

sub _replace_helper {
    my ($tree, $ft, $tt, $matches) = @_;

    my $type = $tree->[0];

    if ($type eq 'num') {
        if (_expr_match($tree, $ft, $matches)) {
            return $tt;
        }
        return $tree;
    }
    elsif ($type eq 'var') {
        if (_expr_match($tree, $ft, $matches)) {
            return $tt;
        }
        return $tree;
    }
    elsif ($type eq 'op') {
        if (_expr_match($tree, $ft, $matches)) {
            return _replace_matches($matches, $tt);
        }
        return [ $type, $tree->[1],
            _replace_helper($tree->[2], $ft, $tt, $matches),
            _replace_helper($tree->[3], $ft, $tt, $matches)
        ];
    }
    elsif ($type eq 'func') {
        if (_expr_match($tree, $ft, $matches)) {
            if ($tt->[0] ne 'func') {
                return _replace_matches($matches, $tt);
            }
            my @args;
            for (0 .. (scalar(@{$tt->[2]})-1)) {
                $args[$_] = _replace_matches($matches, $tt->[2][$_]);
            }
            return [ 'func', _replace_matches($matches, $tt->[1]), \@args ];
        }
        my @args;
        for (0 .. (scalar(@{$tree->[2]})-1)) {
            $args[$_] = _replace_helper($tree->[2][$_], $ft, $tt, $matches);
        }
        return [ 'func', _replace_helper($tree->[1], $ft, $tt, $matches), \@args ];
    }
    elsif ($type eq 'tree') {
        if ($tree->[0] eq 'tree' && $ft->[0] eq 'tvar' && $tree->[1] eq $ft->[1]) {
            return $tt;
        }
        return $tree;
    }
    elsif ($type eq 'line') {
        return [ 'line',
            _replace_helper($tree->[1], $ft, $tt, $matches),
            _replace_helper($tree->[2], $ft, $tt, $matches),
        ];

    }
    die "Unknown type $type";
}

sub replace {
    my ($source, $from, $to) = @_;

    my $st = parse_rr($source);
    my $ft = parse_rr($from);
    my $tt = parse_rr($to);

    my %matches;
    my $tree = _replace_helper($st, $ft, $tt, \%matches);
    return serialize($tree);
}

sub serialize {
    my ($tree) = @_;
    my @node = @$tree;

    my $type = shift @node;

    if ($type eq 'num') {
        return $node[0];
    }
    elsif ($type eq 'var') {
        return $node[0];
    }
    elsif ($type eq 'op') {
        my $l = serialize($node[1]);
        my $r = serialize($node[2]);
        return '(' . join (' ', $l.$node[0].$r) . ')';
    }
    elsif ($type eq 'tree') {
        return $node[0];
    }
    elsif ($type eq 'func') {
        return serialize($node[0]) . '('.join(", ", map{ serialize($_) } @{$node[1]}).')';
    }
    elsif ($type eq 'line') {
        return serialize($node[0]) .";\n".serialize($node[1]);
    }
    die "Unknown type $type";
}

package RR::Actions;
use strict;
use Data::Dumper;

sub new {
    my ($class) = @_;
    return bless {}, $class;
}

sub do_first_arg {
    shift;
    return $_[0];
}

sub do_num {
    shift;
    return [ 'num', $_[0] ];
}

sub do_var {
    shift;
    return [ 'var', $_[0] ];
}

sub do_tree_var {
    shift;
    return [ 'tree', $_[0] ];
}

sub do_expr {
    shift;
    return [ 'op', $_[1], $_[0], $_[2] ];
}

sub do_list {
    shift;
    return \@_;
}

sub do_null {
    return undef;
}

sub do_join {
    shift;
    return join '', @_;
}

sub do_func {
    shift;
    return [ 'func', $_[0], $_[2] ];
}
sub do_arg1 {
    shift;
    return $_[1];
}

sub do_arg02 {
    shift;
    return ['line', $_[0], $_[2]];
}

1;

test.pl

use RR 'replace';

my $source = <<"SOURCE";
10 + 1000 * power(10*x,n)
SOURCE

my $newsource = replace($source, '10+:a', '22+:a');

print replace($newsource, ':a(100)', 'h(10)') . "\n";