package Hades;

use 5.006;
use strict;
use warnings;
our $VERSION = '0.02';
use Module::Generate;
use Switch::Again qw/switch/;

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

sub run {
	my ($class, $args) = @_;
	$args->{eval} = _read_file($args->{file}) if $args->{file};
	my $mg = Module::Generate->start;
	$args->{$_} && $mg->$_($args->{$_}) for (qw/dist lib author email version/); 
	my $self = $class->new($args);
	my ($index, $ident, @lines, @line, @innerline, $nested) = (0, '');
	while ($index < length $self->{eval}) {
		my $first_char = $self->index($index++);
		$ident =~ m/^:.*\(/ 
			? do {
				my $copy = $ident;
				while ($copy =~ s/\([^()]+\)//g) {}
				if ($copy =~ m/\(|\)/) {
					$ident .= $first_char;
				} else {
					push @innerline, $ident;
					$ident = '';
				}
			}
			: $first_char =~ m/\s/ && $ident !~ m/^$/
				? $nested && $nested == 1
					? $ident =~ m/^(:|\$|\%|\@|\&)/ ? do {
						push @innerline, $ident;
						$ident = '';
					} : do {
						push @line, [@innerline] if scalar @innerline;
						@innerline = ($ident);
						$ident = '';
					} : $nested 
						? do {
							push @innerline, $ident;
							$ident = '';
						} : do {
							push @line, $ident;
							$ident = '';
						}
				: $first_char =~ m/\{/
					? ! $nested 
						? $nested++
						: do {
							push @innerline, '{';
							$nested++;
						}
					: $first_char =~ m/\}/ && do { $nested--; 1; } 
						? ! $nested 
							? do {
								push @line, [@innerline] if @innerline;
								push @lines, [@line] if @line;
								(@innerline, @line) = ((), ());
							} 
							: do {
								push @innerline, '}';
								if ($nested == 1) {
									push @line, [@innerline];
									@innerline = ();
								}
							}
						: do {
							$ident .= $first_char unless $first_char =~ m/\s/;	
						};
	}
	if (scalar @lines) {
		my $last_token;
		for my $class (@lines) {
			if ($class->[0] eq 'macro') {
				shift @{$class};
				$mg->macro(shift @{$_}, join(' ', @{$_}) . ';') for @{$class};
				next;
			}
			while ($class->[0] =~ m/^(dist|lib|author|email|version)$/) {
				$mg->$1($class->[1]);
				shift @{$class}, shift @{$class};
			}
			my %meta;
			$mg->class(shift @{$class})->new;
			for my $token (@{$class}) {
				! ref $token
					? $token =~ m/^(parent|base|require|use)$/ 
						? do {
							$last_token = $token;			
						} : do {
							$mg->$last_token($token);				
						}
					: scalar @{$token} == 1
						? do {
							$meta{$token->[0]}->{type} = 'ACCESSOR';
							$mg->accessor($token->[0]);
						}
						: $token->[1] eq '{'
							? do {
								my $name = shift @{$token};
								$name =~ m/^(begin|unitcheck|check|init|end|new)$/
									? $mg->$name(join ' ', @{$token})
									: $mg->sub($name)->code(join ' ', @{$token});
							} : do {
								my $name = shift @{$token};
								$name =~ m/^(our)$/
									? $mg->$name( '(' . join( ', ', @{$token}) . ')')
									: $name =~ m/^(synopsis|abstract)$/
										? $mg->$name(join ' ', @{$token})
										: do {
											$meta{$name}->{type} = 'ACCESSOR';
											my $switch = switch(
												qr/\:required|\:r/ => sub {
													$meta{$name}->{required} = 1;
												},
												qr/^(\:default|\:d)/ => sub {
													my $value = shift;
													$value =~ s/.*\((.*)\)/$1/;
													$value = '"' . $value . '"' 
														if $value !~ m/^(\{|\[|\"|\'|q)|(\d+)/;
													$meta{$name}->{default} =  $value; 
												}
											);
											$switch->(shift @{$token}) while scalar @{$token};
											$meta{$name}->{type} eq 'ACCESSOR'
												? $mg->accessor($name)
												: $mg->sub($name)->code($meta{$name}->{code});
										}
							};
			}
			my %class = %Module::Generate::CLASS;
			my $accessors = q|(|;
			map {
				$accessors .= qq|$_ => {|;
				$accessors .= qq|required=>1,| if $meta{$_}{required};
				$accessors .= qq|default=>$meta{$_}{default},| if $meta{$_}{default};
				$accessors .= qq|},|;
			} grep { $meta{$_}{type} eq 'ACCESSOR' } keys %meta;
			$accessors .= q|)|;
			my $new = $class{CURRENT}{PARENT} || $class{CURRENT}{BASE} ? 'my $self = $cls->SUPER::new(%args)' : 'my $self = bless {}, $cls';		
			my $code = qq|{
				my (\$cls, \%args) = (shift(), scalar \@_ == 1 ? \%{\$_[0]} : \@_);
				$new;
				my \%accessors = $accessors; 
				for my \$accessor ( keys \%accessors ) {
					my \$value = \$self->\$accessor(\$args{\$accessor} \/\/ \$accessors{\$accessor}->{default});
					unless (!\$accessors{\$accessor}->{required} \|\| defined \$value) {
						die "\$accessor accessor is required";
					}
				}
				return \$self;
			}|;
			$class{CURRENT}{SUBS}{new}{CODE} = $code;
		}
	}
	$mg->generate;
}

sub _read_file {
	my ($file) = @_;
	open my $fh, '<', $file;
	my $content = do { local $/; <$fh>; };
	close $fh;
	return $content;
}

sub index {
	my ($self, $index) = @_;
	return substr $self->{eval}, $index, 1;
}

1;

__END__

=head1 NAME

Hades - The great new Hades!

=head1 VERSION

Version 0.02

=cut

=head1 SYNOPSIS

	use Hades;

	Hades->run({
		eval => 'Kosmos { penthos :d(2) curae :r nosoi :default(2) geras { if ($_[0]->penthos == $_[0]->nosoi) { return $_[0]->curae; } } }'
	});

	... generates ...

	package Kosmos;
	use strict;
	use warnings;
	our $VERSION = 0.01;

	sub new {
		my ( $cls, %args ) = ( shift(), scalar @_ == 1 ? %{ $_[0] } : @_ );
		my $self = bless {}, $cls;
		my %accessors = (
			nosoi   => { default  => 2, },
			curae   => { required => 1, },
			penthos => { default  => 2, },
		);
		for my $accessor ( keys %accessors ) {
			my $value = $self->$accessor( $args{$accessor}
				    // $accessors{$accessor}->{default} );
			unless ( !$accessors{$accessor}->{required} || defined $value ) {
				die "$accessor accessor is required";
			}
		}
		return $self;
	}

	sub penthos {
		my ( $self, $value ) = @_;
		if ( defined $value ) {
			$self->{'penthos'} = $value;
		}
		return $self->{'penthos'};
	}

	sub curae {
		my ( $self, $value ) = @_;
		if ( defined $value ) {
			$self->{'curae'} = $value;
		}
		return $self->{'curae'};
	}

	sub nosoi {
		my ( $self, $value ) = @_;
		if ( defined $value ) {
			$self->{'nosoi'} = $value;
		}
		return $self->{'nosoi'};
	}
	
	sub geras {
		if ( $_[0]->penthos == $_[0]->nosoi ) { return $_[0]->curae; }
	}
	
	1;

	__END__

=head1 SUBROUTINES/METHODS

=head2 run

=over

=item file

Provide a file to read in.

=item eval

Provide a string to eval.

=item dist

Provide a name for the distribution.

=item lib

Provide a path where the generated files will be compiled.

=item author

The author of the distribution/module.

=item email

The authors email of the distribution/module.

=item version

The version number of the distribution/module.

=back

=cut

=head1 AUTHOR

LNATION, C<< <email at lnation.org> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-hades at rt.cpan.org>, or through
the web interface at L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Hades>.  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 Hades

You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=Hades>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Hades>

=item * CPAN Ratings

L<https://cpanratings.perl.org/d/Hades>

=item * Search CPAN

L<https://metacpan.org/release/Hades>

=back


=head1 ACKNOWLEDGEMENTS


=head1 LICENSE AND COPYRIGHT

This software is Copyright (c) 2020 by LNATION.

This is free software, licensed under:

  The Artistic License 2.0 (GPL Compatible)


=cut

1; # End of Hades
