Aion
19 results

 view release on metacpan or  search on metacpan

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

		my ($self) = @_;
		sub { $self->test }
	},
	'""' => "stringify",
	"|" => sub { Aion::Types::Union([@_[0, 1]]) },
	"&" => sub { Aion::Types::Intersection([@_[0, 1]]) },
	"~" => sub { Aion::Types::Exclude([shift]) },
	"~~" => "include",
	">>" => "coerce",
	"eq" => "identical",
	"ne" => "distinct",
	"lt" => sub {die "lt do'nt used!"},
	"gt" => sub {die "gt do'nt used!"},
	"le" => sub {die "le do'nt used!"},
	"ge" => sub {die "ge do'nt used!"},
	"cmp" => "compare",
	"<=>" => "compare",
	"==" => "equals",
	"!=" => "differs",
	">=" => "superset",
	"<=" => "subset",
	">" => "superproper",
	"<" => "subproper",
;

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

$Aion::Type::SELF = __PACKAGE__->new(
		is_param_args => __PACKAGE__->new(name => "Argument_ARGS", is_param => -1024),
	is_param => -256,
	name => 'Argument_SELF',
	args => [
		__PACKAGE__->new(name => "Argument_A", is_param => 1),
		__PACKAGE__->new(name => "Argument_B", is_param => 2),
		__PACKAGE__->new(name => "Argument_C", is_param => 3),
		__PACKAGE__->new(name => "Argument_D", is_param => 4),
	],
	N => __PACKAGE__->new(name => "Argument_N", is_param => -1),
	M => __PACKAGE__->new(name => "Argument_M", is_param => -2),
);

# конструктор
# * name (Str) — Имя типа.
# * as (Object[Aion::Type]) — наследуемый тип.
# * args (ArrayRef) — Список аргументов.
# * init (ArrayRef[CodeRef]) — Инициализатор типа.
# * test (CodeRef) — Чекер.
# * a_test (CodeRef) — Используется для проверки типа с аргументами, если аргументы не указаны, то используется test.
# * coerce (ArrayRef) — Массив преобразователей в этот тип: [Type => sub {}]. Общий для экземплятов параметрического типа.
# * subset (CodeRef) - Проверка на подмножество типа A типу B.
# * message (CodeRef) — Сообщение об ошибке.
# * title (Str) — Заголовок.
# * description (Str) — Описание.
# * example (Any) — Пример.
# * is_option (Bool) – это Option[A].
# * is_wantarray (Bool) – это Wantarray[A, S].
# * ally (Bool) – вступать в союз для объединения ветвей наследования при пересечении типов.
sub new {
	my $cls = shift;
	my $self = bless {@_}, $cls;
	$self->{test} //= \&test;
	$self->{coerce} //= [];
	$self
}

# Клонировать тип
sub clone {
	my $self = shift;
	$self = bless { %$self, @_ }, ref $self;
	delete @$self{qw/key as_test_cache/};
	$self
}

# Инициализировать тип
sub init {
	my ($self) = @_;
	
	# Есть параметрические типы – не инициализируем
	return $self if $self->{args} && List::Util::first { UNIVERSAL::isa($_, __PACKAGE__) && exists $_->{is_param} } @{$self->{args}};

	local $Aion::Type::SELF = $self;
	$_->() for @{$self->{init}};

	$self
}

#@category strings

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

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

	$self->is_union? join "", "( ", join(" | ", @args), " )":
	$self->is_intersection? join "", "( ", join(" & ", @args), " )":
	$self->is_exclude? "~$args[0]":
	join("", $self->{name}, @args? ("[", join(", ", @args), "]") : ());
}

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

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

#@category test

# Строит кеш для вызова только для примитивного типа
sub _build_as_test_cache {
	my ($self) = @_;

	my @as;
	for(my $i = $self->{as}; $i; $i = $i->{as}) {
		return "" if $i->is_set_theoretic;
		unshift @as, $i if $i->{test} != \&true;
	}
	
	\@as;

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


# A <= B  <=>  A & ~B = ∅
sub subset {
	my ($self, $other) = @_;

	return 1 if $self eq $other or $other eq Any;

 	($self & ~$other)->_simplify eq None;
}

# A < B (Строгое включение: подтип, но не равен) = A <= B && !(B <= A)
sub subproper {
	my ($self, $other) = @_;
	$self->subset($other) && !$other->subset($self);
}

# A >= B = B <= A
sub superset {
	my ($self, $other) = @_;
	$other->subset($self);
}

# A > B = B < A
sub superproper {
	my ($self, $other) = @_;
	$other->subproper($self);
}

# A == B (Эквивалентность типов: A является подтипом B И B является подтипом A) = A <= B && B <= A
sub equals {
	my ($self, $other) = @_;
	$self eq $other || $self->subset($other) && $other->subset($self);
}

# A != B
sub differs {
	my ($self, $other) = @_;
	!$self->equals($other);
}

# Пересекаются
sub joint {
	my ($self, $other) = @_;
	!$self->disjoint($other);
}

# Не пересекаются
sub disjoint {
	my ($self, $other) = @_;
	($self & $other)->_simplify eq None;
}

#@category swagger

# Заголовок
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
	}
}

#@category makers

# Создаёт функцию для типа
sub make {
	my ($self, $pkg) = @_;
	
	die "init_where won't work in $self->{name}" 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, $is_arg) = @_;

	my $hash = "%$self->{name}";
	my $proto = $is_arg? '$': '';

	if($is_arg) {
		my $init = $self->{init}? '->init': '';
		my $code = "package $pkg {
		my $hash = %\$self;
		sub $self->{name} (\$) { Aion::Type->new($hash, args => \$_[0])$init }
	}";
		eval $code;
		die if $@;
		return $self;
	}
	
	my $code = "package $pkg {
	my $hash = %\$self;
	sub $self->{name} () { Aion::Type->new($hash)->init }
}";
	eval $code;
	die if $@;

	$self
}

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

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



( run in 0.541 second using v1.01-cache-2.11-cpan-6aa56a78535 )