package Hades;

use 5.006;
use strict;
use warnings;
our $VERSION = '0.03';
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]}->{meta} = '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}->{meta} = 'ACCESSOR';
											my $switch = switch(
												qr/^(\:clearer|\:c)$/ => sub {
													$meta{$name}->{clearer} = 1;
												},	
												qr/^(\:default|\:d)/ => sub {
													my $value = shift;
													$value =~ s/.*\((.*)\)/$1/;
													$value = '"' . $value . '"' 
														if $value !~ m/^(\{|\[|\"|\'|q)|(\d+)/;
													$meta{$name}->{default} =  $value; 
												},
												qr/^(\:required|\:r)$/ => sub {
													$meta{$name}->{required} = 1;
												},
												qr/^(\:type|\:t)/ => sub {
													my $value = shift;
													$value =~ s/.*\((.*)\)/$1/;
													$meta{$name}->{type} =  $value; 
												}
											);
											$switch->(shift @{$token}) while scalar @{$token};
											if ($meta{$name}->{meta} eq 'ACCESSOR') {
												my $type = $self->build_type($name, $meta{$name}->{type});
												my $code = qq|{
													my ( \$self, \$value ) = \@_;
													if ( defined \$value ) { $type
														\$self->{$name} = \$value;
													}
													return \$self->{$name};
												}|;
												$mg->accessor($name)->code($code);
											} else { 
												$mg->sub($name)->code($meta{$name}->{code});
											}
											if ($meta{$name}->{clearer}) {
												$mg->sub(qq|clear_$name|)
												->code(qq|{
													my (\$self) = \@_;
													delete \$self->{$name};
													return \$self;
												}|)
												->pod(qq|clear $name accessor|)
												->example(qq|\$obj->clear_$name|);
											}
										}
							};
			}
			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{$_}{meta} 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(defined \$args{\$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 build_type {
	my ($self, $name, $type, $value, $error_string, $code) = @_;
	$value ||= '$value';
	$code ||= '';
	if ($type) {
		$error_string ||=  qq|die qq{$type: invalid value $value for accessor $name};|;
		my $switch = switch
			qr/^(Any)$/ => sub {
				return '';
			},
			qr/^(Item)$/ => sub {
				return '';
			},
			qr/^(Bool)$/ => sub {
				return qq|
					my \$ref = ref $value;
					if ((\$ref \|\| 'SCALAR') ne 'SCALAR' \|\| (\$ref ? \$$value : $value) !~ m/^(1\|0)\$/) {
						$error_string
					}
					$value = !!(\$ref ? \$$value : $value) ? 1 : 0;|;
			},
			qr/^(Str)$/ => sub {
				return qq|
					if (ref $value \|\| $value !~ m/.+/) {
						$error_string
					}|;
			},
			qr/^(Num)$/ => sub {
				return qq|
					if (ref $value \|\| $value !~ m/^[-+\\d]\\d*\\.?\\d\*\$/) {
						$error_string
					}|;
			},
			qr/^(Int)$/ => sub {
				return qq|
					if (ref $value \|\| $value !~ m/^[-+\\d]\\d\*\$/) {
						$error_string
					}|;
			},
			qr/^(Ref)$/ => sub {
				return qq|
					if (! ref $value) {
						$error_string
					}|;
			},
			qr/^(Ref\[(.*)\])$/ => sub {
				my ($val, @matches) = @_;
				$matches[1] = '"' . $matches[1] . '"' if $matches[1] =~ m/^[a-zA-Z]/;
				return qq|
					if ((ref($value) \|\| "") ne $matches[1]) {
						$error_string
					}|;
			},
			qr/^(ScalarRef)$/ => sub {
				return qq|
					if ((ref($value) \|\| "") ne "SCALAR") {
						$error_string
					}|;
			},
			qr/^(ScalarRef\[(.*)\])$/ => sub {
				my ($val, @matches) = @_;
				$matches[1] = '"' . $matches[1] . '"' if $matches[1] =~ m/^[a-zA-Z]/;
				return qq|
					if ((ref($value) \|\| "") ne $matches[1]) {
						$error_string
					}|;
			},
			qr/^(ArrayRef)$/ => sub {
				return qq|
					if ((ref($value) \|\| "") ne "ARRAY") {
						$error_string
					}|;
			},
			qr/^(ArrayRef\[(.*)\])$/ => sub {
				my ($val, @matches) = @_;
				@matches = map { my $h = $_; $h =~ s/^\s*|\s*//g; $h; } split ',', $matches[1];
				my $code = qq|
					if ((ref($value) \|\| "") ne "ARRAY") { 
						$error_string 
					}|;
				my $new_error_string = $self->extend_error_string($error_string, $value, '$item', qq| expected $matches[0]|);
				my $sub_code = $self->build_type($name, $matches[0], '$item', $new_error_string);
				$code .= qq|
					for my \$item (\@{ $value }) {$sub_code
					}| if $sub_code;
				$code .= qq|
					my \$length = scalar \@{$value};| 
				if $matches[1] || $matches[2];
				$code .= qq|
					if (\$length < $matches[1]) { 
						die qq{ArrayRef for $name must contain atleast $matches[1] items} 
					}|
				if defined $matches[1];
				$code .= qq|
					if (\$length > $matches[2]) { 
						die qq{ArrayRef for $name must not be greater than $matches[2] items} 
					}|
				if defined $matches[2];
				return $code;
			},
			qr/^(HashRef)$/ => sub {
				return qq|
					if ((ref($value) \|\| "") ne "HASH") {
						$error_string
					}|;
			},
			qr/^(HashRef\[(.*)\])$/ => sub {
				my ($val, @matches) = @_;
				my $code = qq|
					if ((ref($value) \|\| "") ne "HASH") {
						$error_string
					}|;
				$error_string =~ s/};$/ expected $matches[1]};/;
				$error_string =~ s/\$value/\$item/;	
				my $sub_code = $self->build_type($name, $matches[1], '$item', $error_string);
				$code .= qq|
					for my \$item (values \%{ $value }) {$sub_code
					}| if $sub_code;
 				return $code;
			},
			qr/^(CodeRef)$/ => sub {
				return qq|
					if ((ref($value) \|\| "") ne "CODE") {
						$error_string
					}|;
			},
			qr/^(RegexpRef)$/ => sub {
				return qq|
					if ((ref($value) \|\| "") ne "Regexp") {
						$error_string
					}|;
			},
			qr/^(GlobRef)$/ => sub {
				return qq|
					if ((ref($value) \|\| "") ne "GLOB") {
						$error_string
					}|;
			},
			qr/^(Object)$/ => sub {
				return qq|
					if ((ref($value) \|\| "") =~ m/^(\|HASH\|ARRAY\|SCALAR\|CODE\|GLOB)\$/) {
						$error_string
					}|;
			},
			qr/^(Map\[(.*)\])$/ => sub {
				my ($val, @matches) = @_;
				@matches = map { my $h = $_; $h =~ s/^\s*|\s*//g; $h; } split ',', $matches[1];
				my $code = qq|
					if ((ref($value) \|\| "") ne "HASH") {
						$error_string
					}|;
				my $key_error_string = $self->extend_error_string($error_string, $value, '$key', qq| expected $matches[0]|);
				my $key_sub_code = $self->build_type($name, $matches[0], '$key', $key_error_string);
				my $value_error_string = $self->extend_error_string($error_string, $value, '$val', qq| expected $matches[1]|);
				my $value_sub_code = $self->build_type($name, $matches[1], '$val', $value_error_string);
				$code .= qq|
					for my \$key (keys \%{ $value }) {
						my \$val = ${value}->{\$key};$key_sub_code$value_sub_code
					}| if $key_sub_code || $value_sub_code;
 				return $code;
			},
			qr/^(Tuple\[(.*)\])$/ => sub {
				my ($val, @matches) = @_;
				@matches = map { my $h = $_; $h =~ s/^\s*|\s*//g; $h; } split ',', $matches[1];
				my $code = qq|
					if ((ref($value) \|\| "") ne "ARRAY") {
						$error_string
					}|;
				my $i = 0;
				for my $match (@matches) {
					(my $new_value = $value) .= qq|->[$i]|;
					my $item_error_string = $self->extend_error_string($error_string, $value, $new_value, qq| expected $match for index $i|);
					my $key_sub_code = $self->build_type($name, $match, $new_value, $item_error_string);
					$code .= $key_sub_code;
					$i++;
				}
				return $code;
			},
			qr/^(Dict\[(.*)\])$/ => sub {
				my ($val, @matches) = @_;
				@matches = split ',', $matches[1];
				my $sub_code;
				while (@matches) {
					my ($match) = (shift @matches);
					if ($match =~ m/(Map|Tuple|ArrayRef|Dict)\[/) {
						my $lame = sub {
							my $copy = shift;
							while ($copy =~ s/\[[^\[\]]+\]//g) {}
							if ($copy =~ m/\[|\[/) {
								return 1;
							} else {
								return 0;
							}
						};
						while ($lame->($match .=  ', ' . shift @matches)) {}
					}
					my ($k, $v) = map { my $h = $_; $h =~ s/^\s*|\s*$//g; $h; } split('=>', $match, 2);
					(my $new_value = $value) .= qq|->{$k}|;
					my $new_error_string = $self->extend_error_string($error_string, $value, $new_value, qq| expected $v for $k|);
					$sub_code .= $self->build_type($k, $v, $new_value, $new_error_string);
				}
				my $code = qq|
					if ((ref($value) \|\| "") ne "HASH") {
						$error_string
					} $sub_code|;
				return $code;
			},
			qr/^(Optional\[(.*)\])$/ => sub {
				my ($val, @matches) = @_;
				my $sub_code = $self->build_type($name, $matches[1], $value, $error_string);
				my $code = qq|
					if (defined $value) { $sub_code
					}|;
				return $code;
			};
		$code .= $switch->($type);
	}
	return $code;
}

sub extend_error_string {
	my ($self, $error_string, $value, $new_value, $message) = @_;
	(my $new_error_string = $error_string) =~ s/\Q$value\E/$new_value/;
	$new_error_string =~ s/};$/$message};/;
	return $new_error_string;
}

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

1;

__END__

=head1 NAME

Hades - The great new Hades!

=head1 VERSION

Version 0.03

=cut

=head1 SYNOPSIS

	use Hades;

	Hades->run({
		eval => 'Kosmos { penthos :d(2) :t(Int) curae :r nosoi :c :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( defined $args{$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 ) {
			if ( ref $value || $value !~ m/^[-+\d]\d*$/ ) {
				die qq{Int: invalid value $value for accessor penthos};
			}
			$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 clear_nosoi {
		my ($self) = @_;
		delete $self->{nosoi};
		return $self;
	}

	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 Hades

=cut

=head2 Class

Declare a new class.

	Kosmos {

	}

=cut

=head3 Inheritance

=cut

=head4 base

Establish an ISA relationship with base classes at compile time.

Unless you are using the fields pragma, consider this discouraged in favor of the lighter-weight parent.

	Kosmos base Kato {

	}

=cut

=head4 parent

Establish an ISA relationship with base classes at compile time.

	Kosmos parent Kato {

	}

=cut

=head4 require

Require library files to be included if they have not already been included.

	Kosmos require Kato {

	}

=cut

=head4 use

Declare modules that should be included in the class.

	Kosmos use Kato Vathys {

	}

=cut

=head2 Compile phase

=cut

=head3 begin

Define a code block is executed as soon as possible.

	Kosmos {
		begin {
			... perl code ...
		}
	}

=cut 

=head3 unitcheck

Define a code block that is executed just after the unit which defined them has been compiled.

	Kosmos {
		unitcheck {
			... perl code ...
		}
	}

=cut

=head3 check

Define a code block that is executed just after the initial Perl compile phase ends and before the run time begins.

	Kosmos {
		check {
			... perl code ...
		}
	}

=cut

=head3 init

Define a code block that is executed just before the Perl runtime begins execution.

	Kosmos {
		init {
			... perl code ...
		}
	}

=cut

=head3 end

Define a code block is executed as late as possible.

	Kosmos {
		end {
			... perl code ...
		}
	}

=cut

=head2 Variables

=cut

=head3 our

Declare variable of the same name in the current package for use within the lexical scope.

	Kosmos {
		our $one %two
	}

=cut

=head2 Accessors

Declare an accessor for the class

	Kosmos {
		dokimi
	}

=cut

=head3 :required | :r

Making an accessor required means a value for the accessor must be supplied to the constructor.
	
	dokimi :r
	dokimes :required

=cut

=head3 :default() | :d() 

The default is used when no value for the accessor was supplied to the constructor.

	dokimi :d(Eimai o monos)
	dokimes :default([{ ola => "peripou", o => [qw/kosmos/] }])

=cut

=head3 :clearer | :c

Setting clearer creates a method to clear the accessor.
	
	dokimi :c
	dokimes :clearer

	$class->clear_dokimi;

=cut

=head3 :type | :t

Add type checking to the accessor.

	dokimi :t(Dict[onoma => Str, id => Optional[Int], epiloges => Dict[onama => Str]])

=cut

=head4 types

=over

=item Any

Absolutely any value passes this type constraint (even undef).

	dokimi :t(Any)

=item Item

Essentially the same as Any. All other type constraints in this library inherit directly or indirectly from Item.

	dokimi :t(Item)

=item Bool

Values that are reasonable booleans. Accepts 1, 0, the empty string and undef.

	dokimi :t(Bool)

=item Str

Any string.

	dokimi :t(Str)

=item Num

Any number.

	dokimi :t(Num)

=item Int 

An integer; that is a string of digits 0 to 9, optionally prefixed with a hyphen-minus character.

	dokimi :t(Int)

=item Ref

Any defined reference value, including blessed objects.

	dokimi :t(Ref)
	dokimes :t(Ref[HASH])

=item ScalarRef
	
A value where ref($value) eq "SCALAR" or ref($value) eq "REF".

	dokimi :t(ScalarRef)
	dokimes :t(ScalarRef[SCALAR])

=item ArrayRef

A value where ref($value) eq "ARRAY".

	dokimi :t(ArrayRef)
	dokimes :t(ArrayRef[Str, 1, 100])

=item HashRef

A value where ref($value) eq "HASH".

	dokimi :t(HashRef)
	dokimes :t(HashRef[Int])

=item CodeRef

A value where ref($value) eq "CODE"

	dokimi :t(CodeRef)

=item RegexpRef

A value where ref($value) eq "Regexp"

	dokimi :t(RegexpRef)

=item GlobRef

A value where ref($value) eq "GLOB"

	dokimi :t(GlobRef)

=item Object

A blessed object.

	dokimi :t(Object)

=item Map

Similar to HashRef but parameterized with type constraints for both the key and value. The constraint for keys would typically be a subtype of Str.

	dokimi :t(Map[Str, Int])

=item Tuple

Accepting a list of type constraints for each slot in the array.

	dokimi :t(Tuple[Str, Int, HashRef])

=item Dict

Accepting a list of type constraints for each slot in the hash.

	dokimi :t(Dict[onoma => Str, id => Optional[Int], epiloges => Dict[onama => Str]])

=item Optional

Used in conjunction with Dict and Tuple to specify slots that are optional and may be omitted.

	dokimi :t(Optional[Str])

=back

=cut

=head2 Methods

Declare a sub routine/method.

	Kosmos {
		dokimi {
			... perl code ...
		}
	}

=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
