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) = @_;