use 5.014;
use strict;
use warnings;

package Kavorka::Multi;

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.033';

use Parse::Keyword {};
use Parse::KeywordX;

use Moo;
with 'Kavorka::Sub';
use namespace::sweep;


has multi_type          => (is => 'ro', required => 1);
has declared_long_name  => (is => 'rwp');
has qualified_long_name => (is => 'rwp');

around parse => sub
{
	my $next  = shift;
	my $class = shift;
	
	lex_read_space;
	my $type = parse_name('keyword', 0);
	lex_read_space;
	
	if ($^H{Kavorka} =~ /\b$type=(\S+)/)
	{
		$type = $1;
	}
	else
	{
		Carp::croak("Could not resolve keyword '$type'");
	}
	
	return $class->$next(@_, multi_type => $type);
};

after parse_attributes => sub
{
	my $self = shift;
	
	my @attr = @{$self->attributes};
	
	my @filtered;

	$_->[0] eq 'long'
		? ($self->_set_declared_long_name($_->[1]), $self->_set_qualified_long_name(scalar Kavorka::_fqname $_->[1]))
		: push(@filtered, $_)
		for @attr;
	
	@{$self->attributes} = @filtered;
};

after parse_signature => sub
{
	my $self = shift;
	my $sig  = $self->signature;
	
	for my $param (@{$sig->params})
	{
		Carp::croak("Type constraints for parameters cannot be 'assumed' in a multi sub")
			if $param->traits->{assumed};
	}
	
	$self->signature->_set_nobble_checks(1);
};

sub allow_anonymous { 0 }
sub allow_lexical   { 0 }

sub default_attributes
{
	my $code = $_[0]->multi_type->can('default_attributes');
	goto $code;
}

sub default_invocant
{
	my $code = $_[0]->multi_type->can('default_invocant');
	goto $code;
}

sub forward_declare
{
	my $code = $_[0]->multi_type->can('forward_declare');
	goto $code;
}

sub invocation_style
{
	$_[0]->multi_type->invocation_style
		or Carp::croak("No invocation style defined");
}

our %DISPATCH_TABLE;
our %DISPATCH_STYLE;
our %INVALIDATION;

sub __gather_candidates
{
	my ($pkg, $subname, $args) = @_;
	
	if ($DISPATCH_STYLE{$pkg}{$subname} eq 'fun')
	{
		return @{$DISPATCH_TABLE{$pkg}{$subname}};
	}
	
	require mro;
	my $invocant = ref($args->[0]) || $args->[0];
	return map @{$DISPATCH_TABLE{$_}{$subname} || [] }, @{ $invocant->mro::get_linear_isa };
}

sub __dispatch
{
	my ($pkg, $subname) = @{ +shift };
	
	for my $c ( __gather_candidates($pkg, $subname, \@_) )
	{
		my @copy = @_;
		next unless $c->signature->check(@copy);
		my $body = $c->body;
		goto $body;
	}
	
	Carp::croak("Arguments to $pkg\::$subname did not match any known signature for multi sub");
}

sub __compile
{
	my ($pkg, $subname) = @_;
	
	my @candidates = __gather_candidates($pkg, $subname, [$pkg]);
	my @coderefs   = map $_->body, @candidates;
	
	my $slowpath = '';
	if ($DISPATCH_STYLE{$pkg}{$subname} ne 'fun')
	{
		my $this = [$pkg, $subname];
		push @{ $INVALIDATION{"$_\::$subname"} ||= [] }, $this for @{ $pkg->mro::get_linear_isa };
		
		$slowpath = sprintf(
			'if ((ref($_[0]) || $_[0]) ne %s) { unshift @_, [%s, %s]; goto \\&Kavorka::Multi::__dispatch }',
			B::perlstring($pkg),
			B::perlstring($pkg),
			B::perlstring($subname),
		);
	}
	
	my $compiled = join q[] => (
		map {
			my $sig = $candidates[$_]->signature;
			$sig && $sig->nobble_checks ? sprintf(
				"\@tmp = \@_; if (%s) { unshift \@_, \$Kavorka::Signature::NOBBLE; goto \$coderefs[%d] }\n",
				$candidates[$_]->signature->inline_check('@tmp'),
				$_,
			) :
			$sig ? sprintf(
				"\@tmp = \@_; if (%s) { goto \$coderefs[%d] }\n",
				$candidates[$_]->signature->inline_check('@tmp'),
				$_,
			) : sprintf('goto \$coderefs[%d];', $_);
		} 0 .. $#candidates,
	);
	
	my $error = "Carp::croak(qq/Arguments to $pkg\::$subname did not match any known signature for multi sub/);";
	
	Sub::Name::subname(
		"$pkg\::$subname",
		eval("package $pkg; sub { $slowpath; my \@tmp; $compiled; $error }"),
	);
}

sub __defer_compile
{
	my ($pkg, $subname) = @_;
	return Sub::Name::subname(
		"$pkg\::$subname" => sub {
			no strict "refs";
			no warnings "redefine";
			*{"$pkg\::$subname"} = (my $compiled = __compile($pkg, $subname));
			goto $compiled;
		},
	);
}

sub install_sub
{
	my $self = shift;
	my ($pkg, $subname) = ($self->qualified_name =~ /^(.+)::(\w+)$/);
	
	unless ($DISPATCH_TABLE{$pkg}{$subname})
	{
		$DISPATCH_TABLE{$pkg}{$subname} = [];
		$DISPATCH_STYLE{$pkg}{$subname} = $self->invocation_style;
	}
	
	$DISPATCH_STYLE{$pkg}{$subname} eq $self->invocation_style
		or Carp::croak("Two different invocation styles used for $subname");
	
	{
		# A placeholder dispatcher that will replace itself with a more
		# efficient optimized (compiled) dispatcher.
		no strict "refs";
		no warnings "redefine";
		*{"$pkg\::$subname"} = __defer_compile($pkg, $subname);
		
		# Invalidate previously optimized dispatchers in subclasses of $pkg
		*{join '::', @$_} = __defer_compile(@$_)
			for @{ delete($INVALIDATION{"$pkg\::$subname"}) || [] };
	}
	
	my $long = $self->qualified_long_name;
	if (defined $long)
	{
		no strict 'refs';
		*$long = $self->body;
	}
	
	push @{ $DISPATCH_TABLE{$pkg}{$subname} }, $self;
}

1;