use v5.14;
use strict;
use warnings FATAL => 'all';
no warnings qw(void once uninitialized numeric);
package Moops::Parser;
our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.027';
use Moo;
use Keyword::Simple ();
use Module::Runtime qw($module_name_rx);
use namespace::sweep;
# I'm just going to assume that 0.01 is the only version that is ever going
# to have that problem...
use PerlX::Define _RT88970 => (Keyword::Simple->VERSION == 0.01) ? 1 : 0;
has 'keyword'    => (is => 'ro');
has 'ccstash'    => (is => 'ro');
has 'ref'        => (is => 'ro');
# Not set in constructor; set by parse method.
has 'package'        => (is => 'rwp', init_arg => undef);
has 'version'        => (is => 'rwp', init_arg => undef, predicate => 'has_version');
has 'relations'      => (is => 'rwp', init_arg => undef, default => sub { +{} });
has 'version_checks' => (is => 'rwp', init_arg => undef, default => sub { [] });
has 'traits'         => (is => 'rwp', init_arg => undef, default => sub { +{} });
has 'is_empty'       => (is => 'rwp', init_arg => undef, default => sub { 0 });
has 'done'           => (is => 'rwp', init_arg => undef, default => sub { 0 });
has 'lines'          => (is => 'rw',  init_arg => undef, default => sub { 0 });
has 'class_for_keyword' => (
        is      => 'lazy',
        builder => 1,
        handles => {
                known_relationships  => 'known_relationships',
                qualify_relationship => 'qualify_relationship',
                version_relationship => 'version_relationship',
        },
);
sub _eat
{
        my $self = shift;
        my ($bite) = @_;
        my $ref = $self->{ref};
         
        if (ref($bite) and $$ref =~ /\A($bite)/sm)
        {
                my $r = $1;
                substr($$ref, 0, length($r)) = '';
                return $r;
        }
        elsif (!ref($bite))
        {
                substr($$ref, 0, length($bite)) eq $bite
                        or Carp::croak("Expected $bite; got $$ref");
                substr($$ref, 0, length($bite)) = '';
                return $bite;
        }
         
        Carp::croak("Expected $bite; got $$ref");
}
sub _eat_space
{
        my $self = shift;
        my $ref = $self->{ref};
         
        my $X;
        while (
                ($$ref =~ m{\A( \s+ )}x and $X = 1)
                or ($$ref =~ m{\A\#} and $X = 2)
        ) {
                $X==2
                        ? $self->_eat(qr{\A\#.+?\n}sm)
                        : $self->_eat($1);
                $self->{lines} += $X==2
                        ? 1
                        : (my @tmp = split /\n/, $1, -1)-1;
        }
        return;
}
sub _peek
{
        my $self = shift;
        my $re   = $_[0];
        my $ref  = $self->{ref};
         
        return scalar($$ref =~ m{\A$re});
}
sub _eat_package
{
        my $self = shift;
        my ($rel) = @_;
        my $pkg = $self->_eat(qr{(?:::)?$module_name_rx});
        return $self->qualify_module_name($pkg, $rel);
}
sub _eat_package_and_version
{
        my $self = shift;
        my ($rel) = @_;
         
        my $pkg = $self->_eat(qr{(?:::)?$module_name_rx});
        $self->_eat_space;
         
        my $ver = $self->_peek_version ? $self->_eat_version : undef;
         
        return (
                $self->qualify_module_name($pkg, $rel),
                $ver,
        );
}
{
        my $v_re = qr{v?[0-9._]+};
        sub _peek_version { shift->_peek($v_re) }
        sub _eat_version  { shift->_eat($v_re) }
}
sub _eat_relations
{
        my $self = shift;
         
        my $RELS = join '|', map quotemeta, $self->known_relationships;
        $RELS = qr/\A($RELS)/sm;
         
        my (%relationships, @vchecks);
        while ($self->_peek($RELS))
        {
                my $rel = $self->_eat($RELS);
                $self->_eat_space;
                 
                my $with_version = $self->version_relationship($rel);
                 
                my ($pkg, $ver) = $with_version ? $self->_eat_package_and_version($rel) : $self->_eat_package($rel);
                my @modules = $pkg;
                push @vchecks, [$pkg, $ver] if $ver;
                $self->_eat_space;
                while ($self->_peek(qr/\A,/))
                {
                        $self->_eat(',');
                        $self->_eat_space;
                        my ($pkg, $ver) = $with_version ? $self->_eat_package_and_version($rel) : $self->_eat_package($rel);
                        push @modules, $pkg;
                        push @vchecks, [$pkg, $ver] if $ver;
                        $self->_eat_space;
                }
                 
                push @{ $relationships{$rel}||=[] }, @modules;
        }
         
        wantarray ? (\%relationships, \@vchecks) : \%relationships;
}
sub _eat_traits
{
        my $self = shift;
         
        my %traits;
        while ($self->_peek(qr/[A-Za-z]\w+/))
        {
                my $trait = $self->_eat(qr/[A-Za-z]\w+/);
                $self->_eat_space;
                 
                if ($self->_peek(qr/\(/))
                {
                        require Text::Balanced;
                        my $code = Text::Balanced::extract_codeblock(${$self->ref}, '()');
                        my $ccstash = $self->ccstash;
                        # stolen from Attribute::Handlers
                        my $evaled = eval("package $ccstash; no warnings; no strict; local \$SIG{__WARN__}=sub{die}; +{ $code }");
                        $traits{$trait} = $evaled;
                        $self->_eat_space;
                }
                else
                {
                        $traits{$trait} = undef;
                }
                 
                if ($self->_peek(qr/:/))
                {
                        $self->_eat(':');
                        $self->_eat_space;
                }
        }
         
        \%traits;
}
sub parse
{
        my $self = shift;
        return if $self->done;
         
        $self->_eat_space;
         
        $self->_set_package(
                $self->_eat_package
        );
         
        $self->_eat_space;
         
        $self->_set_version(
                $self->_eat_version
        ) if $self->_peek_version;
         
        $self->_eat_space;
         
        if ($self->known_relationships)
        {
                my ($rels, $vchecks) = $self->_eat_relations;
                $self->_set_relations( $rels );
                $self->_set_version_checks( $vchecks );
        }
         
        $self->_eat_space;
         
        if ($self->_peek(qr/:/))
        {
                $self->_eat(':');
                $self->_eat_space;
                $self->_set_traits($self->_eat_traits);
                $self->_eat_space;
        }
         
        $self->_peek(qr/;/) ? $self->_set_is_empty(1) : $self->_eat('{');
         
        # We subtract 1 to work around RT#88970 when possible.
        # This obviously won't solve anything if lines == 0
        substr(${$self->{ref}}, 0, 0, ("\n" x ($self->{lines} - _RT88970)));
         
        # But we can try.
        ${$self->{ref}} =~ s/\A[\t\r\x20]*\n//ms if _RT88970 && !$self->{lines};
         
        $self->_set_done(1);
}
sub keywords
{
        qw/ class role namespace library /;
}
sub qualify_module_name
{
        my $self = shift;
        my ($bareword, $rel) = @_;
        my $caller = $self->ccstash;
         
        return $1                    if $bareword =~ /^::(.+)$/;
        return $bareword             if $caller eq 'main';
        return $bareword             if $bareword =~ /::/;
        return "$caller\::$bareword" if !defined($rel) || $self->qualify_relationship($rel);
        return $bareword;
}
sub _build_class_for_keyword
{
        my $self = shift;
        my $kw = $self->keyword;
         
        if ($kw eq 'class')
        {
                require Moops::Keyword::Class;
                return 'Moops::Keyword::Class';
        }
        elsif ($kw eq 'role')
        {
                require Moops::Keyword::Role;
                return 'Moops::Keyword::Role';
        }
        elsif ($kw eq 'library')
        {
                require Moops::Keyword::Library;
                return 'Moops::Keyword::Library';
        }
         
        require Moops::Keyword;
        return 'Moops::Keyword';
}
sub keyword_object
{
        my $self = shift;
        my (%attrs) = @_;
         
        my $class = $self->class_for_keyword;
         
        if (my %traits = %{$self->traits || {}})
        {
                require Moo::Role;
                $class = 'Moo::Role'->create_class_with_roles(
                        $self->class_for_keyword,
                        map("Moops::TraitFor::Keyword::$_", keys %traits),
                );
                 
                for my $trait (keys %traits)
                {
                        next unless defined $traits{$trait};
                        $attrs{sprintf('%s_%s', lc($trait), $_)} = $traits{$trait}{$_}
                                for keys %{$traits{$trait}};
                }
        }
         
        $class->new(
                package        => $self->package,
                (version       => $self->version) x!!($self->has_version),
                relations      => $self->relations,
                is_empty       => $self->is_empty,
                keyword        => $self->keyword,
                ccstash        => $self->ccstash,
                version_checks => $self->version_checks,
                %attrs,
        );
}
1;