view release on metacpan or  search on metacpan

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

	my %o = @_;
	
	my ($as, $init_where, $where, $awhere, $message) = delete @o{qw/as init_where where awhere message/};
	
	die "subtype $subtype unused keys left: " . join ", ", keys %o if keys %o;
	
	die "subtype format is Name or Name[args] or Name`[args]" if $subtype !~ /^([A-Z_]\w*)(?:(\`)?\[(.*)\])?$/i;
	my ($name, $is_maybe_arg, $is_arg) = ($1, $2, $3);

	my $pkg = scalar caller;
	die "subtype $subtype: ${pkg}::$name exists!" if *{"${pkg}::$name"}{CODE};

	if($is_maybe_arg) {
		die "subtype $subtype: needs an awhere" if !$awhere;
	} else {
		die "subtype $subtype: awhere is excess" if $awhere;
	}

	my @init = $init_where? $init_where: ();
	
	my $init_types = do { given($is_arg) {
		$INIT_ARGS when /^[A-Z]\w*(,\s*[A-Z]\w*)?\.\.\.$/;
		$INIT_KW_ARGS when /^[a-z]\w*\s*=>\s*[A-Z],?\s*\.\.\.$/;
		when(/\b[A-Z]\b/) {
			my @args = split /\s*,\s*/, $is_arg;
			my @typeno = grep { $args[$_] =~ /^[A-Z]/ } 0..@args-1;
			(sub { my ($typeno) = @_; sub {
				my $args = &ARGS;
				$args->[$_] = External([$args->[$_]]) for @$typeno;
			} })->(\@typeno);
		}
	}};

	unshift @init, $init_types if $init_types;
	
	$as = External([$as]) if defined $as;
	
	unshift @init, $INIT_REPLACE_PARAM if $as && $is_arg && $IS_PARAM->($as);

	# Тут coerce - прототип - единый для всех порождаемых типов одного типа с разными аргументами
	my $type = Aion::Type->new(
		name => $name,
		coerce => [], # prototype
		test => $where // \&Aion::Type::true,
		$as? (as => $as): (),
		@init? (init => \@init): (),
		$awhere? (a_test => $awhere): (),
		$message? (message => $message): (),
	);
	
	if($is_maybe_arg) {
		$type->make_maybe_arg($pkg)
	} elsif($is_arg || @init) {
		$type->make_arg($pkg, $is_arg)
	} else {
		$type->make($pkg)
	}
}
}

sub as(@) { (as => @_) }
sub init_where(&@) { (init_where => @_) }
sub where(&@) { (where => @_) }
sub awhere(&@) { (awhere => @_) }
sub message(&@) { (message => @_) }

sub SELF() { $Aion::Type::SELF }
sub ARGS() {
	return $Aion::Type::SELF->{is_param_args} if $Aion::Type::SELF->{is_param_args};
	wantarray? @{$Aion::Type::SELF->{args}}: $Aion::Type::SELF->{args}
}
sub A() { $Aion::Type::SELF->{args}[0] }
sub B() { $Aion::Type::SELF->{args}[1] }
sub C() { $Aion::Type::SELF->{args}[2] }
sub D() { $Aion::Type::SELF->{args}[3] }

sub M() :lvalue { $Aion::Type::SELF->{M} }
sub N() :lvalue { $Aion::Type::SELF->{N} }

# Создание транслятора. У типа может быть сколько угодно трансляторов из других типов
# coerce Type, from OtherType, via {...}
sub coerce(@) {
	my ($type, %o) = @_;
	my ($from, $via) = delete @o{qw/from via/};

	die "coerce $type unused keys left: " . join ", ", keys %o if keys %o;
	die "coerce $type not Aion::Type!" unless UNIVERSAL::isa($type, "Aion::Type");
	die "coerce $type: from is'nt Aion::Type!" unless UNIVERSAL::isa($from, "Aion::Type");
	die "coerce $type: via is not subroutine!" unless ref $via eq "CODE";

	push @{$type->{coerce}}, [$from, $via];
	return;
}

sub from($) { (from => $_[0]) }
sub via(&) { (via => $_[0]) }

use constant DBL_MAX => do {
	my $ieee_dbl_max_str = '1.7976931348623157e+308';
	($ieee_dbl_max_str+0) =~ /inf/i? do {
		require Math::BigFloat;
		Math::BigFloat->new($ieee_dbl_max_str)
	}: $ieee_dbl_max_str+0
};

sub _8BITS() {
	undef *_8BITS;
	require Math::BigInt;
	my $_8bits = Math::BigInt->new(8);
	constant->import(_8BITS => $_8bits);
	$_8bits
}

BEGIN {

subtype "Any";
	subtype "Control", as &Any;
        subtype "Union[A, B...]", as &Control,
            where { my $val = $_; any { $_->include($val) } ARGS };
        subtype "Intersection[A, B...]", as &Control,
            where { my $val = $_; all { $_->include($val) } ARGS };