#!/usr/bin/perl

package Blondie::Backend::C::Emitter;
use base qw/Blondie::Emitter Blondie::Reducer::DynamicScoping/;

use strict;
use warnings;

use UNIVERSAL::moniker;
use String::Escape qw/quote printable/;
use Blondie::Reducer::DuplicateFinder;
use Blondie::TypeSafe;
use Set::Object ();

{
	package Blondie::Backend::C::Emitter::DuplicateFinder;
	use base qw/Blondie::Reducer::DuplicateFinder/;

	sub generic_reduce {
		my $self = shift;
		my $node = shift;

		my $struct = $node->struct_equiv;
		my $orig = $node->orig;

		if (defined($orig) and $self->{seen}->includes($orig)) {
			$self->{dups}->insert($orig);
			return;
		} else {
			if (defined($orig) and not(Scalar::Util::blessed($struct) and $struct->isa("Blondie::Val"))) {
				$self->{seen}->insert($orig);
			}
			$self->Blondie::Reducer::generic_reduce($node->struct_equiv);
		}
	}
}

sub new {
	my $class = shift;
	bless {
		defs => [],
		defined_nodes => Set::Object->new,
		names => {},
	}, $class;
}

sub reduce {
	my $self = shift;
	my $node = shift;

	my $h = Devel::STDERR::Indent::indent;
	warn "annotation: $node";
	warn "reducing " . $node->struct_equiv; #. Data::Dumper::Dumper($node->struct_equiv);

	if ($self->has_symbol($node)){
		return $self->symbolic_representation($node);
	}

	my $symbol = $self->declare($node) if $self->is_duplicate($node);
	warn $node->struct_equiv . " is duplicated, and has been alocated $symbol" if defined $symbol;

	my $result = $self->inner_reduce($node);
	
	if (defined $symbol) {
		return $self->define($node, $symbol, $result);
	} else {
		return $result;
	}
}

sub inner_reduce {
	my $self = shift;
	my $node = shift;
	return $self->literal_value($node) unless Scalar::Util::blessed($node->struct_equiv);

	if (my $meth = $self->can("reduce_" . $node->struct_equiv->moniker)) {
		return $self->$meth($node);
	} else {
		return $self->generic_reduce($node);
	}
}

sub literal_value {
	my $self = shift;
	my $node = shift;
	
	my $t = $self->t($node);

	if ($t eq "IV") {
		return $node->struct_equiv;
	} elsif ($t eq "PV") {
		return quote(printable($node->struct_equiv));
	} else { die "don't know to make a literal out of $t" }
}

sub generic_reduce {
	my $self = shift;
	my $node = shift;

	warn "generic reduction over " . $node->struct_equiv;

	my $reduced_struct = $self->SUPER::generic_reduce($node->struct_equiv);
	(ref $node)->new(%$node, struct_equiv => $reduced_struct);
}

sub can_reduce {
	my $self = shift;
	my $node = shift;
	Scalar::Util::blessed($node->struct_equiv);
}

sub t {
	my $self = shift;
	my $node = shift;

	$self->resolve_type($node->type);
}

sub resolve_type {
	my $self = shift;
	my $type = shift;

	$type = $type->type while Scalar::Util::blessed($type);
	$type = $type->[0] while ref $type and @$type == 1;
	$type;
}

sub has_symbol {
	my $self = shift;
	my $node = shift;

	exists $self->{names}{$node->orig};
}

sub declare {
	my $self = shift;
	my $node = shift;

	$self->{names}{$node->orig} ||= do {
		my $struct = $node->struct_equiv;
		my $type = Scalar::Util::blessed($struct) ? $struct->moniker : "const";
		join("_", $type, ++$self->{counters}{$type});
	}
}

sub define {
	my $self = shift;
	my ($node, $symbol, $body) = @_;

	return if $self->node_is_defined($node);

	return $self->define_literal(@_) unless $self->can_reduce($node);

	my $kind = $node->struct_equiv->moniker;
	my $method = "define_$kind";
	warn "defining a new $kind (@_)";
	return $self->$method(@_);
}

sub define_prim {
	my $self = shift;
	my ($node, $symbol, $body) = @_;

	return $body;
}

sub define_literal {
	my $self = shift;
	my ($node, $symbol, $body) = @_;

	my $type = $self->resolve_type($node);
	
	$self->add_definition($node, "const $type $symbol = $body;");

	return $symbol;
}

sub define_thunk {
	my $self = shift;
	my ($node, $symbol, $body) = @_;

	# all thunks with protos were already defined as functions
	
	my $type = $self->resolve_type($node); # unlike parametered thunks these thunk have no -> type

	$self->define_named_block($node, $symbol, $body, $type);
}

sub define_app {
	my $self = shift;
	my ($node, $symbol, $body) = @_;

	$self->define_named_block($node, $symbol, $body, $self->resolve_type($node));
}

sub define_named_block {
	my $self = shift;
	my ($node, $symbol, $body, $type) = @_;
	$self->add_definition($node, "$type $symbol () {\n\t$body;\n}");
	return $symbol . "()";
}

sub define_val {
	my $self = shift;
	my ($node, $symbol, $body, $type) = @_;
	return $body;
}

sub symbolic_representation {
	my $self = shift;
	my $node = shift;

	$self->{names}{$node->orig};
}

sub is_duplicate {
	my $self = shift;
	my $node = shift;

	$self->{dups}->includes($node->orig);
}

sub reduce_val {
	my $self = shift;
	my $val = shift;

	$self->reduce($val->struct_equiv->val);
}

sub add_definition {
	my $self = shift;
	my $node = shift;
	my $body = shift;

	push @{ $self->{defs} }, $body;

	$self->mark_defined($node);
}

sub mark_defined {
	my $self = shift;
	my $node = shift;

	$self->{defined_nodes}->insert($node);
}

sub node_is_defined {
	my $self = shift;
	my $node = shift;
	$self->{defined_nodes}->includes($node);
}

sub reduce_thunk {
	my $self = shift;
	my $node = shift;

	my $thunk = $node->struct_equiv;
	my $child = $thunk->val->struct_equiv;

	if ($child->isa("Blondie::Seq")){ # FIXME if (has_params)
		my $symbol = $self->declare($node);

		my $return_type = $node->type->[-1]->type;
		
		my @children = $child->values;
		my @params;
		my @exps;

		$self->enter_scope;
		while(@children) {
			my $sub = shift @children;
			if ($sub->struct_equiv->isa("Blondie::Param")) {
				push @params, $self->resolve_type($sub->accepts_type) ." ". (my $sym = $self->reduce($sub));
				$self->new_pad($sub->struct_equiv->val->struct_equiv => $sym);
			} else {
				push @exps, $self->reduce($sub);
			}
		}
		$self->leave_scope;
		
		my $last_exp = pop @exps;
	
		$self->add_definition($node => "$return_type $symbol (" . join(", ", @params) . ") {" . join("\n\t", "", (map { "$_;" } @exps), "return $last_exp;") . "\n}");

		return $symbol;
	} else {
		$self->reduce($thunk->val);
	}
}

sub reduce_sym {
	my $self = shift;
	my $node = shift;

	$self->find_immediate_dyn_sym($node->struct_equiv->val->struct_equiv)->val;
}

sub reduce_param {
	my $self = shift;
	my $node = shift;

	$self->mangle_sym_name($node->struct_equiv->val->struct_equiv);
}

sub mangle_sym_name {
	my $self = shift;
	my $sym = shift;

	require charnames;
	
	$sym =~ s/([^a-z0-9_])/charnames::viacode(ord($1)) . "__"/ge;
	$sym =~ s/\s+/_/g;

	"sym__" . lc($sym);
}

sub reduce_seq {
	my $self = shift;
	my $node = $self->generic_reduce(shift);

	my $seq = $node->struct_equiv;
	join("\n\t", "", map { "$_;" } $seq->values);
}

sub emit {
	my $self = shift;
	my $prog = shift;

	use Data::Dumper;
	$Data::Dumper::Maxdepth = 4;
	#$Data::Dumper::Indent = 1;
	$Data::Dumper::Terse = 1;
	#warn Dumper($prog);

	my $dup_finder = Blondie::Backend::C::Emitter::DuplicateFinder->new;
	$self->{dups} = Set::Object->new( $dup_finder->duplicate_nodes($prog) );

	my $main = $self->reduce($prog);
	my $type = $self->resolve_type($prog);

	push @{ $self->{defs} }, "$type b_main () {\n\treturn $main;\n}";
	push @{ $self->{defs} }, "int main () { b_main(); return 0; }";

	join("\n\n", Blondie::Backend::C::Builtins->prelude, @{$self->{defs}});
}

sub reduce_app {
	my $self = shift;
	my $app = shift;

	my $rapp = $self->generic_reduce($app);

	my ($thunk, @params) = $rapp->struct_equiv->values;

	my $orig_thunk = ($app->struct_equiv->values)[0]->struct_equiv->val->struct_equiv; # eep!
	if ($orig_thunk->isa("Blondie::Backend::C::Prim") and ($orig_thunk->fixity || "") eq "infix") {
		return "( $params[0] $thunk $params[1] )";
	} else {
		return "$thunk( " . join(", ", @params) . " )";
	}
}

sub reduce_prim {
	my $self = shift;
	my $prim = shift;

	$prim->struct_equiv->body;
}

__PACKAGE__;

__END__

=pod

=head1 NAME

Blondie::Backend::C::Emitter - 

=head1 SYNOPSIS

	use Blondie::Backend::C::Emitter;

=head1 DESCRIPTION

=cut