package Tapir::Server::Handler::Signatures;

use strict;
use warnings;
use Devel::Declare::Context::Simple;

use base qw(Exporter);
our @EXPORT = qw(set_service);

our $ALLOW_REDEFINE = 0;

sub set_service ($) {
	my $class = caller;
	$class->service(@_);
}

sub import {
	my ($class, %args) = @_;
	my $caller = caller;
	$class->setup_for($caller, \%args);

	# Allow Exporter to do its thing
	$class->export_to_level(1, @_);
}

sub setup_for {
	my ($class, $pkg, $args) = @_;

	# Create a wrapper for the parser() call to capture $pkg
	my $parser = sub {
		my $context = Devel::Declare::Context::Simple->new(into => $pkg);
		parser($context, @_);
	};

	Devel::Declare->setup_for(
		$pkg,
		{ method => { const => $parser } }
	);
	{
		no strict 'refs';
		*{ $pkg . '::method' } = sub (&) {};
	}
}

sub parser {
	my $ctx = shift;
	$ctx->init(@_);

	$ctx->skip_declarator;
	my $name  = $ctx->strip_name;
	my $proto = $ctx->strip_proto;
	my $attrs = parse_attrs($ctx->strip_attrs);

	# Figure out what to inject based on the prototype
	my $inject = parse_proto($proto);

	# Add the method name onto the Handler->methods() accessor
	my $pkg = $ctx->{into};

	# Record some meta information about this in the class accessors
	my $after_block = '';
	my $modifier = $attrs ? ", \\'$attrs\\'" : '';
	$after_block = "$pkg->add_method(\\'$name\\'$modifier);";

	# Ensure that ';' occurs at the end of the block
	$inject = $ctx->scope_injector_call("; $after_block") . $inject;

	# Do the inject
	$ctx->inject_if_block($inject);

	if (defined $name) {
		$name = join('::', $ctx->get_curstash_name(), $name)
			unless ($name =~ /::/);
		$ctx->shadow(sub (&) {
			no strict 'refs';
			# In testing, it's convenient to redefine methods over and over; let's allow that
			# via the class global $ALLOW_REDEFINE
			if ($ALLOW_REDEFINE) {
				no warnings 'redefine';
				*{$name} = shift;
			}
			else {
				*{$name} = shift;
			}
		});
	}
	else {
		$ctx->shadow(sub (&) { shift });
	}
}

sub parse_attrs {
	my $attrs = shift;
	$attrs ||= '';

	return '' if $attrs eq '';

	$attrs =~ s/^://;
	$attrs =~ s/^\s+//;
	$attrs =~ s/\s+$//;

	return $attrs;
}

sub parse_proto {
	my $proto = shift;
	$proto ||= '';

	my $inject = "my (\$class, \$call) = \@_;";

	foreach my $part (split /\s* , \s*/x, $proto) {
		# scalar '$var'
		if ($part =~ m{\$(\S+)}) {
			$inject .= "my $part = \$call->arguments->field_named('$1')->value_plain();";
		}
		else {
			die "Unrecognized handler signature '$proto' (failed at '$part')";
		}
	}

	return $inject;
}

1;
