Transforming Syntax – Tree Cloning example

gistfile1.pl

use strict; use warnings; use 5.010;
use Data::Dumper;

my $ast = bless( [
                 [
                   bless( [
                            bless( [
                                     bless( [
                                              bless( ['Myvalue.xyz'], 'Ast::Var' ),
                                              '==',
                                              bless( ['1'], 'Ast::Literal' )
                                            ], 'Ast::Binop' ),
                                     'Or',
                                     bless( [
                                              bless( ['Frmae_1.signal_1'], 'Ast::Var' ),
                                              '==',
                                              bless( ['1'], 'Ast::Literal' )
                                            ], 'Ast::Binop' )
                                   ], 'Ast::Binop' ),
                            bless( [
                                     bless( ['a'], 'Ast::Var' ),
                                     '=',
                                     bless( ['1'], 'Ast::Literal' )
                                   ], 'Ast::Binop' ),
                            bless( [
                                     bless( ['a'], 'Ast::Var' ),
                                     '=',
                                     bless( ['0'], 'Ast::Literal' )
                                   ], 'Ast::Binop' )
                          ], 'Ast::Cond' )
                 ]
               ], 'Ast::Block' );
            
print Dumper $ast;
print Dumper $ast->clone;

say "The trees are equivalent" if Dumper($ast) eq Dumper($ast->clone);


# AST classes below

package Ast;
    use Scalar::Util qw/blessed/;

    sub new {
        my ($class, @args) = @_;
        bless \@args => $class;
    }
    sub childs { @{ shift() } }
    
    sub clone {
        my ($self) = @_;
    	my @childs = map { blessed($_) && $_->can("clone") ? $_->clone : $_ } $self->childs;
        ref($self)->new(@childs);
    }

package Ast::Binop;
    use parent -norequire, 'Ast';

    sub l   { shift()->[0] }
    sub op  { shift()->[1] }
    sub r   { shift()->[2] }

package Ast::Var;
    use parent -norequire, 'Ast';

    sub name { shift()->[0] }

package Ast::Cond;
    use parent -norequire, 'Ast';

    sub cond { shift()->[0] }
    sub then { shift()->[1] }
    sub else { shift()->[2] }

package Ast::Block;
    use parent -norequire, 'Ast';

    sub contents { shift()->[0] }

    sub new { 
        my ($class, @items) = @_;
		$class->SUPER::new(\@items);
    }
    sub childs { @{ shift()->contents } }

package Ast::Literal;
    use parent -norequire, 'Ast';

    sub val { shift()->[0] }