view release on metacpan or  search on metacpan

lib/Aion/Type.pm  view on Meta::CPAN

package Aion::Type;
# Базовый класс для типов и преобразователей
use common::sense;

use Aion::Meta::Util qw//;
use Scalar::Util qw/looks_like_number/;

use overload
	"fallback" => 1,
	"&{}" => sub {
		my ($self) = @_;
		sub { $self->test }
	},	# Чтобы тип мог быть выполнен, как функция
	'""' => "stringify",									# Отображать тип в трейсбеке в строковом представлении
	"|" => sub {
		my ($type1, $type2) = @_;
		__PACKAGE__->new(name => "Union", args => [$type1, $type2], test => sub { $type1->test || $type2->test });
	},
	"&" => sub {
		my ($type1, $type2) = @_;
		__PACKAGE__->new(name => "Intersection", args => [$type1, $type2], test => sub { $type1->test && $type2->test });
	},
	"~" => sub {
		my ($type1) = @_;
		__PACKAGE__->new(name => "Exclude", args => [$type1], test => sub { !$type1->test });
	},
	"~~" => "include",
	"eq" => "equal",
	"ne" => "nonequal",
	">>" => "coerce",
;

Aion::Meta::Util::create_getters(qw/name args as me/);
Aion::Meta::Util::create_accessors(qw/message/);

$Aion::Type::SELF = {
	A => __PACKAGE__->new(name => "Argument_A"),
	B => __PACKAGE__->new(name => "Argument_B"),
	C => __PACKAGE__->new(name => "Argument_C"),
	D => __PACKAGE__->new(name => "Argument_D"),
	N => __PACKAGE__->new(name => "Argument_N"),
	M => __PACKAGE__->new(name => "Argument_M"),
};

# конструктор
# * name (Str) — Имя типа.
# * as (Object[Aion::Type]) — наследуемый тип.
# * args (ArrayRef) — Список аргументов.
# * init (CodeRef) — Инициализатор типа.
# * test (CodeRef) — Чекер.
# * a_test (CodeRef) — Используется для проверки типа с аргументами, если аргументы не указаны, то используется test.
# * coerce (ArrayRef) — Массив преобразователей в этот тип: [Type => sub {}].
# * message (CodeRef) — Сообщение об ошибке.
# * title (Str) — Заголовок.
# * description (Str) — Описание.
# * example (Any) — Пример.
# * me (Str) — Только для типа Me: пакет в котором он был объявлен.
sub new {
	my $cls = shift;
	bless {@_}, $cls;
}

# Строковое представление
sub stringify {
	my ($self) = @_;

	my @args = map {
		UNIVERSAL::isa($_, __PACKAGE__)?
			$_->stringify:
			Aion::Meta::Util::val_to_str($_)
	} @{$self->{args}};

	$self->{name} eq "Union"? join "", "( ", join(" | ", @args), " )":
	$self->{name} eq "Intersection"? join "", "( ", join(" & ", @args), " )":
	$self->{name} eq "Exclude"? (
		@args == 1? join "", "~", @args:
			join "", "~( ", join(" | ", @args), " )"
	):
	join("", $self->{name}, @args? ("[", join(", ", @args), "]") : ());
}

sub equal {
	my ($self, $type) = @_;

	return 1 if Scalar::Util::refaddr $self == Scalar::Util::refaddr $type;
	return "" unless UNIVERSAL::isa($type, __PACKAGE__);	
	return "" unless $self->{name} eq $type->{name};
	return "" unless @{$self->{args}} == @{$type->{args}};
	return "" unless $self->{as} && $self->{as}->equal($type->{as})
		|| !$self->{as} && !$type->{as};

	my $i = 0;
	for my $arg (@{$self->{args}}) {
		return "" unless $arg eq $type->{args}[$i++];
	}

	return 1;
}

sub nonequal {
	my ($self, $type) = @_;
	!$self->equal($type)
}

# Тестировать значение в $_
sub test {
	my ($self) = @_;
	local $Aion::Type::SELF = $self;
	my $ok = $self->{test}->();
	$ok
}

# Инициализировать тип
sub init {
	my ($self) = @_;
	local $Aion::Type::SELF = $self;
	$self->{init}->();
	$self
}

lib/Aion/Type.pm  view on Meta::CPAN

	$self->test
}

# Не является элементом множества описываемого типом
sub exclude {
	(my $self, local $_) = @_;
	!$self->test
}

# Сообщение об ошибке
sub detail {
	(my $self, local $_, my $name) = @_;
	local $Aion::Type::SELF = $self;
	local $Aion::Type::SELF->{N} = $name;
	$self->{message}? $self->{message}->():
		"$name must have the type $self. The it is ${\
			Aion::Meta::Util::val_to_str($_)
		}!"
}

# Валидировать значение в параметре
sub validate {
	(my $self, local $_, my $name) = @_;
	die $self->detail($_, $name) if !$self->test;
	$_
}

# Преобразовать значение в строку
sub val_to_str {
	my ($self, $val) = @_;
	Aion::Meta::Util::val_to_str($val)
}

# Преобразовать значение в параметре и вернуть преобразованное
sub coerce {
	(my $self, local $_) = @_;
	local $Aion::Type::SELF = $self;
	
	for my $coerce (@{$self->{coerce}}) {
		return $coerce->[1]() if $coerce->[0]{test}();
	}
	$_
}

# Определяет, что тип является подтипом другого типа
sub instanceof {
	my ($self, $name) = @_;
	$name = $name->{name} if ref $name;
	for(my $type = $self; $type; $type = $type->{as}) {
		return 1 if $type->{name} eq $name;
	}
	""
}

# Заголовок
sub title {
	my ($self, $title) = @_;
	if(@_ == 1) {
		$self->{title}
	} else {
		bless {%$self, title => $title}, ref $self
	}
}

# Описание
sub description {
	my ($self, $description) = @_;
	if(@_ == 1) {
		$self->{description}
	} else {
		bless {%$self, description => $description}, ref $self
	}
}

# Описание
sub example {
	my ($self, $description) = @_;
	if(@_ == 1) {
		$self->{example}
	} else {
		bless {%$self, example => $description}, ref $self
	}
}

# Создаёт функцию для типа
sub make {
	my ($self, $pkg) = @_;

	die "init_where won't work in $self" if $self->{init};

	my $var = "\$$self->{name}";

	my $code = "package $pkg {
	my $var = \$self;
	sub $self->{name} () { $var }
}";
	eval $code;
	die if $@;

	$self
}

# Создаёт функцию для типа c аргументом
sub make_arg {
	my ($self, $pkg, $proto) = @_;

	my $var = "\$$self->{name}";
	my $init = $self->{init}? "->init": "";
	$proto //= '$';

	my $code = "package $pkg {

	my $var = \$self;

	sub $self->{name} ($proto) {
		Aion::Type->new(
			%$var,
			args => \$_[0],
		)$init
	}
}";
	eval $code;
	die if $@;

	$self
}

# Создаёт функцию для типа c аргументом или без
sub make_maybe_arg {
	my ($self, $pkg) = @_;

	my $var = "\$$self->{name}";
	my $init = $self->{init}? "->init": "";

	my $code = "package $pkg;

	my $var = \$self;

	sub $self->{name} (;\$) {
		\@_==0? $var:
		Aion::Type->new(