package Grammar::DAG::Compiler;

use warnings;
use strict;
no strict 'subs';
no strict 'refs';
no warnings 'redefine';

use Grammar::DAG::Parser;
use File::Slurp qw/slurp/;
use File::Basename;
use Archive::Extract;
use Storable qw/dclone/;

use Data::Dumper; # XXX

my $init_path;

my $to = [
		{ by_ext => __t_by_ext },
		{ by_depth => __t_by_depth },
		{ by_name => __t_by_name },
	];
my $to_current = [];
my $to_ignore = [];

my $TMP = '/tmp';

=head1 NAME

Grammar::DAG::Compiler - xxx

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.01';


=head1 SYNOPSIS

Quick summary of what the module does.

Perhaps a little code snippet.

    use Grammar::DAG::Compiler;

    my $source = ...;
    my $dag = Grammar::DAG::Cmpiler->new();

    $dag->run();

=head1 EXPORT

A list of functions that can be exported.  You can delete this section
if you don't export anything, such as for a purely object-oriented module.

=head1 SUBROUTINES/METHODS

=head2 new

=cut

sub new {
	my ($class) = shift;
	my $self = bless({}, $class);

	return $self;
}

=head2 run

=cut

sub run {
	my ($self,$source,$path) = @_;

	if ($path =~ m/(tgz|tar\.gz)$/i) {
		$path = $self->__handle_archive($path);
	}

	$path = '.' unless $path;
	my $ptree = parser($source);
	$self->dag($ptree->{'%DAG'});
	$self->tail($ptree->{'%TAIL'});
	$self->pre($ptree->{'%PRE'});
	$self->init_path($path);
	$init_path = $path;
#print Dumper $self->pre;
#return;

	eval $self->tail;
	$self->__pre_typeof();
	$self->__process($path);
}

sub __handle_archive {
	my ($self,$path) = @_;

	my $rand = int(rand(999999));
	my $target = "$TMP/dag_$rand";
	mkdir $target unless -e $target;

	{
		no warnings 'redefine';

		my $ae = Archive::Extract->new( archive => $path );
		$ae->extract( to=>"$target" );
	}

	return $target;
}

sub __process {
	my ($self,$path) = @_;

	my @files = ();
	if (-d $path) {
		opendir DIR, $path;
		while (my $file = readdir(DIR)) {
			# XXX
			push @files, "$path/$file" unless $file =~ m/^(\.{1,2}|\_\_)/;
		}
		close DIR;
	}

	foreach (@files) {
		$self->__process($_);
	}

	# find element type
	$to_current = dclone($to);
	my $type = $self->typeof($path,'');
	my $first;
	while (ref $type eq 'SCALAR') {
		$first = $$type;
		$type = $self->typeof($path,$$type);
	}
	$type = $first unless $type;
	print "*** DEBUG: path ${path}::[$type]\n";

	my $files_by_type = {};
	foreach (@files) {
		push @{$files_by_type->{$type}}, $_;
	}

	my $rhs;
	if (exists $self->dag->{$type}) {
		$rhs = $self->dag->{$type};

		my $code;
		if (exists $rhs->{'%MONO'}) {
			$code = $rhs->{'%MONO'};

			my $result = $self->__mono_exec($path,$type,$code);
		}
	}

#print Dumper $self->{'dag'};
#print Dumper $rhs;
#print Dumper \@files;
#print Dumper $files_by_type;
}

sub dag {
   my $self = shift;

   $self->{'dag'} = shift if @_;
   $self->{'dag'};
}

sub tail {
   my $self = shift;

   $self->{'tail'} = shift if @_;
   $self->{'tail'};
}

sub pre {
   my $self = shift;

   $self->{'pre'} = shift if @_;
   $self->{'pre'};
}

sub init_path {
   my $self = shift;

   $self->{'init_path'} = shift if @_;
   $self->{'init_path'};
}

sub __mono_exec {
	my ($self,$path,$type,$code) = @_;

	my $dag = $self->dag->{$type};

	# set $_c -- content if is file
	my $_c = (-f $path) ? slurp $path : '';

	# set $_p -- full path
	my $_p = $path;

	# set $_n -- if isfile filename, if isdir last dir name in path
	my $_n = basename($path) || '';

	# set $_t -- item type
	my $_t = $type;

	my $i = 1;
	my $_l = [];
	@$_l[0] = {'_t'=>$type, '_n'=>$_n, '_p'=>$_p};
	foreach (@{$dag->{'%RHS'}}) {
		my ($id, $quantifier);
      foreach my $k (keys %$_) {
			$id = $k;
         $quantifier = $_->{$k};
      }
		my $value = '';
		if ($self->{'mono'}->{$id}) {
			@$_l[$i] = $self->{'mono'}->{$id};
			my @tmp;
			foreach ( @{@$_l[$i]} ) {
				push(@tmp, $_->{'_v'}) if($_->{'_v'});
			}
			# XXX allow arbitrary join
			my $sub_name = '';
			foreach my $i (@{$self->pre}) {
				foreach my $j (%$i) {
					$sub_name = $i->{$j} if ($j eq 'join');
				}
			}
			if ($sub_name) {
				$value = &$sub_name(@tmp);
			}
			else {
					$value = (@tmp>0) ? join("\n", @tmp) : '';
			}

		}
		$self->{'mono'}->{$id} = undef;
		$_[$i] = $value;
		$i++;
	}

	# set $_j -- join of rhs results
	my @tmp;
	for (my $j=1; $j<$i ; $j++) {
		push(@tmp, $_[$j]) if $_[$j];
	}
	my $_j;
	# XXX allow arbitrary join
	my $sub_name = '';
	foreach my $i (@{$self->pre}) {
		foreach my $j (%$i) {
			$sub_name = $i->{$j} if ($j eq 'join');
		}
	}
	if ($sub_name) {
		$_j = &$sub_name(@tmp);
	}
	else {
		$_j = join "\n", @tmp;
	}

	my $source .= $code;
	my $result = eval $source;
	if ($@) {
		print STDERR "EVAL ERROR: $@";
	}
	my $store = {'_t'=>$_t, '_n'=>$_n, '_p'=>$_p, '_v'=>$result};

	push @{$self->{'mono'}->{$type}}, $store;
}

sub __get_attrs {
   my ($self,$rhs) = @_;

	my @attrs = keys %$rhs;
	@attrs = grep {!/^%/} @attrs;
}

sub __t_by_ext {
	my $path = shift;
#print "DEBUG __t_by_ext $path\n";

	#$path =~ m/\.tex$/ and return 'Latex';
	#$path =~ m/\.png$/ and return 'Imagem';
	$path =~ m/\.(\w+)$/ and return $1;
	return undef;
}

sub __t_by_depth {
	my ($path,$levels) = @_;

	my @levels = @$levels;
	if (-d $path) {
		$path =~ s#$init_path#init_path/#;
		my @a = split /\/+/, $path;
		if (@levels) {
			(@levels >= @a) ? return $levels[@a-1] : return "level".@a;
		}
		else {
			return "level".@a;
		}
	}
	else { return undef; }
}

sub __t_by_name {
	my $path = shift;

	$path =~ m/\w+$/ and return basename($path);
	return undef;
}

sub __t_by_meta {
	my $path = shift;
	return undef unless $path;

	my $type;
	if (-f $path and -f "${path}__META") {
		$type = slurp "${path}__META";
	}
	if (-d $path and -f "$path/__META") {
		$type = slurp "$path/__META";
	}
	if ($type) {
		$type =~ s/(\s|\n)*$//g;
		return $type;
	}
	else {
		return undef;
	}
}

sub __pre_typeof {
	my $self = shift;

	# user defined tipifiers on the head
	foreach my $h (@{$self->pre}) {
		my($value,$key);
		foreach (keys %$h) {
			$key = $_;
			$value = $h->{$key};
		}
		if ($key =~ m/^t_ignore/) {
			my @ignore_list = @{$value};
			unless (@ignore_list) { # XXX one element only
				push @ignore_list, $value;
			}
			push @$to_ignore, @ignore_list;

			next;
		}

		my $orig = $key;
		my $append = $key =~ s/_append$//;
		if ($key =~ m/^t_(\w+)/) {
			my $id = $1;
			my $sub = $value;

			# remover old tipifier if exists
			my $new = [];
			foreach my $a (@{$to}) {
				foreach (keys %$a) {
					#print "testing $_ remover $key\n";
					push(@$new, $a) unless ("t_$_" eq $key);
				}
			}
			$to = dclone($new);

			$append ? push(@$to, {$id=>$sub}) : unshift(@$to, {$id=>$sub});
		}
	}

	# universal tipifier goes first
	unshift @$to, {'by_meta'=>'__t_by_meta'};

	# XXX
	# add adivinhar tipo no fim do array -- last
}

sub typeof {
	my ($self,$path) = @_;

	while (my $x = shift @$to_current) {
		my ($id, $sub);
		foreach my $k (keys %$x) {
			$id = $k;
			$sub = $x->{$id};
		}

		# skip tipifiers in ignore list
		next if (grep {$id eq $x} @$to_ignore);

		# XXX
		my @l = ();
		foreach my $i (@{$to}) {
			foreach my $j (%$i) {
				@l = $i->{$j} if ($j eq 'by_depth');
			}
		}
		# /XXX

		my $type;
		if ($id eq 'by_depth' and @l) {
			my @levels = @l;
			unless (@levels) { # XXX only one member in list
				@levels = ($self->pre->{'t_by_depth'});
			}
			$type = __t_by_depth($path,@levels);
		}
		else {
			if ($sub =~ m/^\w+$/) {
				$type = &$sub($path);
			}
			else {
				$type = eval $sub;
			}
		}
		return $type if $type;
	}
}


=head2 parser

=cut

sub parser {
	my $source = shift;

	my $parser = Grammar::DAG::Parser->new;
	$Grammar::DAG::Parser::rt = $source;
	my $t = $parser->YYParse(
					yylex => \&Grammar::DAG::Parser::yylex,
					yyerror => \&Grammar::DAG::Parser::yyerror
				);
}

=head1 AUTHOR

Nuno Carvalho, C<< <smash at cpan.org> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-grammar-dag at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Grammar-DAG>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.




=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Grammar::DAG


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Grammar-DAG>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Grammar-DAG>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Grammar-DAG>

=item * Search CPAN

L<http://search.cpan.org/dist/Grammar-DAG/>

=back


=head1 ACKNOWLEDGEMENTS


=head1 LICENSE AND COPYRIGHT

Copyright 2010 Nuno Carvalho.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.


=cut

1; # End of Grammar::DAG::Compiler