package Emitter::Perl5;

use strict;
use Pugs::Emitter::Rule::Perl5;
our %nodes;

sub emit_node {
	die "unknown node type: $_[0]" unless $node::{$_[0]};
	no strict 'refs';
	return &{"node::$_[0]"}($_[1]);
}

sub emit {
    my $n = $_[0];
    # local $Data::Dumper::Indent = 0;
    # print "emit: ", ref($n)," ",Dumper( $n ), "\n";

    # $n = $n->{match};

    if ( $n eq ',') {
        return ',';
    }
    if ( ! defined $n || ref($n) eq '' ) {
        # empty node; maybe a <null> match
        return '';
    }
    if ( ref( $n ) eq 'ARRAY' ) {
        my @s;
        for ( @$n ) {
            push @s, emit( $_ );
        }
        return join( '', @s ) ;
    }
    elsif ( ref( $n ) eq 'HASH' ) {
        my ( $k ) = keys %$n;
        my $v = $n->{$k};
        return '' unless defined $k;
	return emit_node($k,$v);
    }
    die "unknown node!! ", Dumper( $n );
}
sub node::pod {
	return ''
}
sub node::ws {
	return ''
}
sub node::string_concat {
    my $a = emit(get_data($_[0], '$<a>'));
    my $b = emit(get_data($_[0], '$<b>'));
	return $a.'.'.$b;
}
sub node::grammar_name {
    my $ident = get_str( $_[0], '$<ident>' );
    return "package $ident;\n";
}
sub node::require_bareword {
    my $ident = get_str( $_[0], '$<ident>' );
    return "require $ident;\n";
}
sub node::use_bareword {
    my $ident = get_str( $_[0], '$<ident>' );
    return "use $ident;\n";
}
sub node::slurp {
    my $var = emit(get_data($_[0], '$<variable>'));
    my $lit = emit(get_data($_[0], '$<value>'));
    return "use Perl6::Slurp;\n".$var." = slurp ".$lit.";\n";
}
sub node::meth_call_term {
    my $ident = get_str( $_[0], '$<class>' );
    my $meth = get_str( $_[0], '$<meth>' );
    my $list = emit( get_data( $_[0], '$<params>' ) );
    return "$ident->$meth($list)";
}
sub node::meth_call {
    my $ident = get_str( $_[0], '$<class>' );
    my $meth = get_str( $_[0], '$<meth>' );
    my $list = emit( get_data( $_[0], '$<params>' ) );
    return "$ident->$meth($list);\n";
}
sub node::sub_call_term {
    my $ident = get_str( $_[0], '$<name>' );
    my $list = emit( get_data( $_[0], '$<params>' ) );
    return "$ident($list)";
}
sub node::sub_call {
    my $ident = get_str( $_[0], '$<name>' );
    my $list = emit( get_data( $_[0], '$<params>' ) );
    return "$ident($list);\n";
}
sub node::rule_decl {
    my $name = get_str( $_[0], '$<ident>' );
    my $program = Pugs::Emitter::Rule::Perl5::emit('Pugs::Grammar::Base', get_data( $_[0], '$<Pugs::Grammar::Rule::rule>' ));
    return "*{'$name'} = \n$program;\n";
}
sub node::perl5_rule_decl {
    # XXX - this sub does only '1' capture
    my $name = get_str( $_[0], '$<ident>' );
    my $regex = get_str( $_[0], '$<perl5_regex>' );
    #print "perl5_rule_decl: $name -- $regex \n";
    my $program =
    "*{'$name'} = sub {" . '
    my $bool = $_[0] =~ /'.$regex.'(.*)$/sx;
    return {
        bool  => $bool,
        match => { \''.$name.'\'=> $1 },
        tail  => $2,
        ( $_[2]->{capture} ? ( capture => [ $1 ] ) : () ),
    }
};
';
    return $program;
}
sub node::block {
    return "\n    {\n" . emit($_[0]) . "\n    }\n";
}
sub node::sub_defin {
    my $id =    get_str( $_[0], '$<ident>' );
    my $block = get_data( $_[0], '$<block>' );
    # XXX - register fixity in grammar
    return 
        # "    { no strict 'refs';\n" .
        "    sub $id\n" . emit($block) . "    ;\n";
}
sub node::sub_decl {
    my $fix =   get_str( $_[0], '$<fix>' );
    my $id =    get_str( $_[0], '$<id>' );
    my $block = get_data( $_[0], '$<block>' );
    # XXX - register fixity in grammar
    return 
        # "    { no strict 'refs';\n" .
        "    *{'$fix:<$id>'} = sub\n" . emit($block) . "    ;\n" .
        "    require Runtime::Perl5::RuleInit;\n".
        # "    }\n" .
        "    push \@Grammar::Perl6::ops, Runtime::Perl5::RuleOps::compile_rule( '" .
            quotemeta( $fix . ':<' . $id . '>' ) . "' );\n";
}
sub node::list {
    my $data = emit(@_);
}
sub node::sub_application {
    my $term1 = emit( get_data( $_[0], '$<term1>' ) );
    my $op =    get_str( $_[0], '$<op>' );
    my $term2 = emit( get_data( $_[0], '$<term2>' ) );
    return 
        "    &{'$op'} ( $term1, $term2 );\n";
}
sub node::assign_hash_to_scalar {
   my $var = emit(get_data($_[0], '$<variable>'));
   my $lit = emit(get_data($_[0], '$<value>'));
   return $var." = \\".$lit.";\n";
}
sub node::access_hash_element {
   my $var = emit(get_data($_[0], '$<variable>'));
   $var =~ s/^\%/\$/;
   my $key = emit(get_data($_[0], '$<key>'));
   return $var."{".$key."}";
}
sub node::access_hashref_element {
   my $var = emit(get_data($_[0], '$<variable>'));
   $var =~ s/^\%/\$/;
   my $key = emit(get_data($_[0], '$<key>'));
   return $var."->{".$key."}";
}
sub node::assign {
   my $var = emit(get_data($_[0], '$<variable>'));
   my $lit = emit(get_data($_[0], '$<value>'));
   return $var.' = '.$lit.";\n";
}
sub node::sub_application_term {
    my $term1 = emit( get_data( $_[0], '$<term1>' ) );
    my $op =    get_str( $_[0], '$<op>' );
    my $term2 = emit( get_data( $_[0], '$<term2>' ) );
    return 
        "    &{'$op'} ( $term1, $term2 )\n";
}
sub node::_push {
    my $op =   get_str( $_[0], '$<op>' );
    my $name = get_str( $_[0], '$<variable>' );
    my $code = get_str( $_[0], '$<code>' );
    return "    $op $name, $code;\n";
}
sub node::_simple_statement {
    my $op = get_str( $_[0], '$<op>' );
    $op = 'warn "not implemented"' if $op eq '...';
    return "    $op;\n";
}
sub node::condition {
    my $op = get_str($_[0],'$<op>');
    my $condition = emit(get_data($_[0],'$<condition>'));
    my $then = emit(get_data($_[0],'$<then>'));
    return "$op ($condition) $then\n";
}
sub node::_my {
    my $op =   get_str( $_[0], '$<op>' );
    my $name = get_str( $_[0], '$<variable>' );
    return "    $op $name;\n";
}
sub node::_return {
    my $val = emit( get_data( $_[0], '$<val>' ) );
    return "    return $val;\n";
}
sub node::_open
{
    my $var = emit(get_data($_[0], '$<variable>'));
    my $lit = emit(get_data($_[0], '$<value>'));
    return "open ".$var.", '>', ".$lit.";\n";
}
sub node::_print {
    my $op   =   get_str( $_[0], '$<op>' );
    my $list = get_data( $_[0], '$<list>' );
    my $cmd = "    print";
    $cmd =    "    warn" if $op eq 'warn';
    $cmd =    "    die " if $op eq 'die';
    my $s;
    for ( @$list ) {
        next unless ref($_) eq 'HASH';
        my $s1 = emit($_);
        $s .= "$cmd $s1;\n"
            if $s1;
    }
    return $s . "$cmd \"\\n\";\n" 
        if $op eq 'say';
    return $s;
}
sub node::_print_with_fh {
    my $op   =   get_str( $_[0], '$<op>' );
    my $list = get_data( $_[0], '$<list>' );
    my $fh   = get_str( $_[0], '$<indirect_object>' );
    my $cmd  = "    print";
    $cmd =    "    warn" if $op eq 'warn';
    $cmd =    "    die " if $op eq 'die';
    my $s;
    for ( @$list ) {
        next unless ref($_) eq 'HASH';
        my $s1 = emit($_);
        $s .= "$cmd $fh $s1;\n"
            if $s1;
    }
    return $s . "$cmd $fh \"\\n\";\n" 
        if $op eq 'say';
    return $s;
}
sub node::term1 {
    return $_[0] unless ref($_[0]);
    return emit( $_[0]->[0]);
}
sub node::term2 {
    return $_[0] unless ref($_[0]);
    return emit( $_[0]->[0]);
}
sub node::literal {
    # $_[0] =~ s/([\'])/\\$1/g;
    return "'" . $_[0] . "'";
    # return '"' . quotemeta($_[0]) . '"';
    #$_[0] =~ s/(["\$%@])/\\$1/g;
    #return '"' . $_[0] . '"';
}
sub node::eval_perl5 {
    my $res = eval emit($_[0]);
    print "Error in eval_perl5:\n", $_[0] if $@;
    die $@ if $@;
    return $res;
}
sub node::varglobal {
   my $a = $_[0];
   $a =~ s/^(.)\*(.+)$/$1$2/;
   return $a;
}
sub node::variable {
    return $_[0];
}
*node::varscalar = *node::varhash = *node::variable;
sub node::empty_list {
    return "()";
}
sub node::immediate_statement_exec {
    return get_data( $_[0], '$<perl5>' );
}
sub node::immediate_statement_rule {
    return emit($_[0]);
}
sub node::macro {
    
            #print Dumper( get_data( $v, "\$()" ) );

            # implementation note: 
            #     $rule and $list are AST
            #     $block is plain text
            
            my ($prefix, $id, $list, $rule, $block) = 
                map { get_data( $_[0], "\$<$_>" ) } 
                qw( prefix id list rule code );
            $prefix = match::str( $prefix );
            $id     = match::str( $id );
            $block  = match::str( $block );
            my @args;
            for ( @$list ) {
                next unless ref($_) eq 'HASH';
                push @args, match::str( $_ );  # emit($_);
            }
            # no parameters? look into the rule for capturable things
            # XXX - more things to look into:
            #     if there is a return-block, then it should be used instead
            unless ( @args ) {
                my %h;
                for ( @$rule ) {
                    next unless ref($_) eq 'HASH';
                    next unless exists $_->{named_capture};
                    
                    for ( @{ $_->{named_capture} } ) {
                        next unless ref($_) eq 'HASH';
                        # XXX - if there are multiple definitions, it is an array
                        my $name = '$' . match::str( $_ );  
                        $h{$name} = 1;
                        last;
                    }
                }
                @args = keys %h;
            } 

            # my $rule_code = Runtime::Perl5::RuleOps::emit_rule( $rule, '' );
            # print "macro: $prefix / $id \n";  #, Dumper($list);
            # print "macro: args = @args\n";
            # print "macro: rule = \n$rule_code\n";
            # print "macro: block = \n", match::str($block),"\n";
    
            # XXX don't use source filter: 
            #     instead, do variable substitutions '$()' in the body's AST
    
            # XXX macro variables can be AST 
            #     - it all depends on the is-parsed rule (TimToady on #perl6)

            my $binding = '';
            for ( 0 .. $#args ) {
                my $ident = $args[$_];
                $ident =~ s/^.//;  # no sigil
                $binding .= 
                    #"    print \"binding: \\n\" . Dumper( match::get( \$_[0], '\$<$ident>' ) );\n" .
                    "    my $args[$_] = " . 
                    "match::str( match::get( \$_[0], '\$<$ident>' ) );\n" .
                    # "    \$src =~ s/\\\\\\$args[$_]/\\$args[$_]/g; \n" .
                    "    $args[$_] =~ s/([\\'\\\\])/\\\\\$1/g;\n" .
                    #"    print \"bound: \\$args[$_] $args[$_] \$src \"; " .
                    "\n";
            }
            # print "macro: var binding: \n$binding";

            # -- end of macro compile-time processing
    
            # emit the macro expander code

            local $Data::Dumper::Pad = '    ' x 2;
            local $Data::Dumper::Terse = 1;
            my $res = 
    
                "*{'$prefix:<$id>'} = sub {\n" .
                "    my \$rule = Runtime::Perl5::RuleOps::concat( \n" .
                "        Runtime::Perl5::RuleOps::constant( '$prefix:<$id>' ),\n" .
                "        \\&Grammar::Perl6::ws_star,\n" .
                Runtime::Perl5::RuleOps::emit_rule( $rule ) .
                "    );\n" .
    
                #"    my \$body_ast = \n" .
                #Data::Dumper->Dump( $block ) .
                #"    ;\n" .
    
                "    my \$match = \$rule->( \@_ );\n" .
                "    return unless \$match;\n" .
                "    my \$code = sub { \n" .
                # "    print 'matched: ', Dumper( \$_[0]->{capture} ); \n" .
                "    my \$src = <<\'!EOT!\'; \n" . 
                $block . 
                "\n!EOT!\n" .
                $binding .
                #"    print 'eval: ', \$a, '  ', \$src; \n" .
                "    \$src =~ s/([\\'\"\\\\])/\\\\\$1/g;\n" .
                "    my \$ret = eval( '\"' . \$src . '\"' ); \n" .
                #"    print \"Error in macro eval:\n\", \$src if \$\@; \n" .
                "    die \$@ if \$\@; \n" .
                #"    \$ret =~ s/([\\'\"])/\\\\\$1/g;\n" .
                #"    print \"ret: ###\$ret### \\n\"; \n" .
                "    my \$ast = Grammar::Perl6::immediate_statement_rule( \$ret );\n" .
                "    die \"compile: syntax error in macro at '\" . \$ast->{tail} . \"'\\n\"\n" .
                "        if \$ast->{tail};\n" .
                #"    print \"ast: \\n\", Dumper( \$ast->{capture} ); \n" .
                "    my \$perl5 = Emitter::Perl5::emit( \$ast->{capture} );\n" .
                #"    print \"perl5: ###\$perl5### \\n\"; \n" .
                "    my \$expanded = eval \$perl5;\n" .
                #"    print \"Error in expanded macro eval:\n\", \$perl5 if \$\@; \n" .
                "    die \$@ if \$\@; \n" .
                #"    print \"expanded: ###\$expanded### \\n\"; \n" .
                "    require Runtime::Perl5::RuleInit;\n".
                "    my \$final_ast = \n" .
                "        Runtime::Perl5::RuleOps::compile_rule( q( [ <?ws>? <\@Grammar::Perl6::statements> ]* <?ws>? ) )\n" .
                "        ->( \$expanded );\n" .
                "    die \"compile: syntax error in macro at '\" . \$final_ast->{tail} . \"'\\n\"\n" .
                "        if \$final_ast->{tail};\n" .
                #"    print \"final ast: \\n\", Dumper(\$final_ast->{capture}); \n" .
                "    return \$final_ast;\n" .
                #"    my \$perl5_final = Emitter::Perl5::emit( \$final_ast->{capture} );\n" .
                #"    print \"perl5_final: ###\$perl5_final### \\n\"; \n" .
                #"    return \$perl5_final;\n" .
                "    };\n" .
                "    my \$ast = \$code->( \$match ); \n" .
                #"    print \"tail: \", \$match->{tail}, \"\\n\"; " .
                "    return { \%\$match, capture => [ \$ast->{capture} ] }; \n" .
                "};\n#endblock\n";
    
            # register new syntax in the grammar category
    
            # example: macro statement_control:<if> ($expr, &ifblock) {...}
            # XXX - this is very rough
            my $category = $prefix;
            $category = 'statements' if $prefix eq 'statement_control';
    
            $res .= "    push \@Grammar::Perl6::$category, \\&{'$prefix:<$id>'};\n";
    
            #print "macro: expanded:\n$res";
            return $res;
};

sub get_data {
    match::get( { capture => $_[0] }, $_[1] ) 
}
sub get_str {
    match::str( get_data( @_ ) )
}
1;