view release on metacpan or  search on metacpan

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

package Aion::Types;
# Типы-валидаторы для Aion

use common::sense;

use Aion::Meta::Util qw/subref_is_reachable/;
use Aion::Type;
use List::Util qw/all any first/;
use Exporter qw/import/;
require overload;
use Scalar::Util qw/looks_like_number reftype refaddr blessed/;
use Sub::Util qw//;

our @EXPORT = our @EXPORT_OK = grep {
	*{$Aion::Types::{$_}}{CODE}	&& !/^(_|(NaN|import|all|any|first|looks_like_number|reftype|refaddr|blessed|subref_is_reachable)\z)/n
} keys %Aion::Types::;

# Обрабатываем атрибут :Isa
sub MODIFY_CODE_ATTRIBUTES {
    my ($pkg, $referent, @attributes) = @_;

    grep { /^Isa\((.*)\)\z/s? do { _Isa($pkg, $referent, $1); 0 }: 1 } @attributes
}

sub _Isa {
	my ($pkg, $referent, $data) = @_;
	my $subname = Sub::Util::subname $referent;
	$subname =~ s/^.*:://;

	die "Anonymous subroutine cannot use :Isa!" if $subname eq '__ANON__';
	
	my @signature = eval "package $pkg; map { UNIVERSAL::isa(\$_, 'Aion::Type')? \$_: __PACKAGE__->can(\$_)? __PACKAGE__->can(\$_)->(): Aion::Types::External([\$_]) } ($data)";
	die if $@;

	die "$pkg\::$subname has no return type!" if @signature == 0;

	require Aion::Meta::Subroutine;
	my $subroutine = Aion::Meta::Subroutine->new(
		pkg => $pkg,
		subname => $subname,
		signature => \@signature,
		referent => $referent,
	);
	
	if(!subref_is_reachable($referent)) {
		$Aion::META{$pkg}{require}{$subname} = $subroutine;
	} else {
		my $require = delete $Aion::META{$pkg}{require}{$subname};
		$require->compare($subroutine) if $require;

		my $overload = $Aion::META{$pkg}{subroutine}{$subname};
		$overload->compare($subroutine) if $overload;
		
		$subroutine->wrap_sub;
	}	
}

BEGIN {
my $TRUE = sub {1};
my $INIT_ARGS = sub { @{&ARGS} = map External([$_]), @{&ARGS} };
my $INIT_KW_ARGS = sub { @{&ARGS} = List::Util::pairmap { $a => External([$b]) } @{&ARGS} };

# Создание типа
sub subtype(@) {
	my $subtype = shift;
	my %o = @_;

	my ($as, $init_where, $where, $awhere, $message) = delete @o{qw/as init_where where awhere message/};

	$as = External([$as]) if defined $as;
	
	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_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);
		}
	}};
	
	if($init_types) {
		$init_where = $init_where
			? (sub { my ($t, $w) = @_; sub { $t->(); $w->() } })->($init_types, $init_where)
			: $init_types;
	}
	
	if($as && $as->{test} != $TRUE) {
		if(!$where && !$awhere) {
			$where = (sub { my ($as) = @_; sub { $as->test } })->($as);
		} else {
			$where = (sub { my ($as, $where) = @_; sub { $as->test && $where->(@_) } })->($as, $where) if $where;
			$awhere = (sub { my ($as, $awhere) = @_; sub { $as->test && $awhere->(@_) } })->($as, $awhere) if $awhere;
		}
	}

	# Тут coerce - прототип - единый для всех порождаемых типов одного типа с разными аргументами
	my $type = Aion::Type->new(name => $name, coerce => []);

	$type->{message} = $message if $message;
	$type->{init} = $init_where if $init_where;
	$type->{as} = $as if $as;

	if($is_maybe_arg) {

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

			my $m = overload::Method($_, '0+');
			Bool()->include($m ? $m->($_) : $_) };
		subtype "Enum[e...]", as &Item, where { $_ ~~ ARGS };
		subtype "Maybe[A]", as &Item, where { !defined($_) || A->test };
		subtype "Undef", as &Item, where { !defined $_ };
		subtype "Defined", as &Item, where { defined $_ };
			subtype "Value", as &Defined, where { "" eq ref $_ };
				subtype "Version", as &Value, where { "VSTRING" eq ref \$_ };
				subtype "Str", as &Value, where { "SCALAR" eq ref \$_ };
					subtype "Uni", as &Str,	where { utf8::is_utf8($_) || /[\x80-\xFF]/a };
					subtype "Bin", as &Str, where { !utf8::is_utf8($_) && !/[\x80-\xFF]/a };
					subtype "NonEmptyStr", as &Str,	where { /\S/ };
					subtype "StartsWith[start]", as &Str,
						init_where { M = qr/^${\ quotemeta A}/ },
						where { $_ =~ M };
					subtype "EndsWith[end]", as &Str,
						init_where { N = qr/${\ quotemeta A}$/ },
						where { $_ =~ N };
					subtype "Email", as &Str, where { /@/ };
					subtype "Tel", as &Str, where { /^\+\d{7,}\z/ };
					subtype "Url", as &Str, where { /^https?:\/\// };
					subtype "Path", as &Str, where { /^\// };
					subtype "Html", as &Str, where { /^\s*<(!doctype\s+html|html)\b/i };
					subtype "StrDate", as &Str, where { /^\d{4}-\d{2}-\d{2}\z/ };
					subtype "StrDateTime", as &Str, where { /^\d{4}-\d{2}-\d{2} \d{2}:\d{2}:\d{2}\z/ };
					subtype "StrMatch[regexp]", as &Str, where { $_ =~ A };
					subtype "ClassName", as &Str, where { !!$_->can('new') };
					subtype "RoleName", as &Str, where { !$_->can('new') && !!(@{"$_\::ISA"} || first { *{$_}{CODE} } values %{"$_\::"}) };
					subtype "StrRat", as &Str, where { m!\s*/\s*!? &Num->include($`) && &Num->include($`): &Num->test };
					subtype "Num", as &Str, where { looks_like_number($_) && /[\dfn]\z/i };
						subtype "PositiveNum", as &Num, where { $_ >= 0 };
						subtype "Int", as &Num,	where { /^[-+]?\d+\z/ };
							subtype "PositiveInt", as &Int, where { $_ >= 0 };
							subtype "Nat", as &Int, where { $_ > 0 };


			subtype "Ref", as &Defined, where { "" ne ref $_ };
				subtype "Tied`[class]", as &Ref,
					where { my $ref = reftype($_); !!(
						$ref eq "HASH"? tied %$_:
						$ref eq "ARRAY"? tied @$_:
						$ref eq "SCALAR"? tied $$_:
						0
					) }
					awhere { my $ref = reftype($_);
						$ref eq "HASH"? A eq ref tied %$_:
						$ref eq "ARRAY"? A eq ref tied @$_:
						$ref eq "SCALAR"? A eq ref tied $$_:
						""
					};
				subtype "LValueRef", as &Ref, where { ref $_ eq "LVALUE" };
				subtype "FormatRef", as &Ref, where { ref $_ eq "FORMAT" };
				subtype "CodeRef", as &Ref, where { ref $_ eq "CODE" };
					subtype "NamedCode[subname]", as &CodeRef, where { Sub::Util::subname($_) ~~ A };
					subtype "ProtoCode[prototype]", as &CodeRef, where { Sub::Util::prototype($_) ~~ A };
					subtype "ForwardRef", as &CodeRef, where { !subref_is_reachable($_) };
					subtype "ImplementRef", as &CodeRef, where { subref_is_reachable($_) };
					subtype "Isa[type...]", as &CodeRef,
						init_where {
						    my $pkg = caller(2);
							SELF->{args} = [ map { External([UNIVERSAL::isa($_, 'Aion::Type')? $_: $pkg->can($_)? $pkg->can($_)->(): $_]) } ARGS ]
						}
						where {
							my $subroutine = $Aion::Isa{pack "J", refaddr $_} or return "";
							my $signature = $subroutine->{signature};
							my $args = ARGS;
							return "" if @$signature != @$args;
							my $i = 0;
							for my $type (@$args) {
								return "" unless $signature->[$i++] eq $type;
							}
							1
						};
				subtype "RegexpRef", as &Ref, where { ref $_ eq "Regexp" };
				subtype "ValueRef`[A]", as &Ref,
					where { ref($_) ~~ ["SCALAR", "REF"] }
					awhere { ref($_) ~~ ["SCALAR", "REF"] && A->include($$_) };
					subtype "ScalarRef`[A]", as &ValueRef,
						where { ref $_ eq "SCALAR" }
						awhere { ref $_ eq "SCALAR" && A->include($$_) };
					subtype "RefRef`[A]", as &ValueRef,
						where { ref $_ eq "REF" }
						awhere { ref $_ eq "REF" && A->include($$_) };
				subtype "GlobRef", as &Ref, where { ref $_ eq "GLOB" };
					subtype "FileHandle", as &GlobRef,
						where { !!*$_{IO} };
				subtype "ArrayRef`[A]", as &Ref,
					where { ref $_ eq "ARRAY" }
					awhere { my $A = A; ref $_ eq "ARRAY" && all { $A->test } @$_ };
				subtype "HashRef`[A]", as &Ref,
					where { ref $_ eq "HASH" }
					awhere { my $A = A; ref $_ eq "HASH" && all { $A->test } values %$_ };
				subtype "Object`[class]", as &Ref,
					where { blessed($_) ne "" }
					awhere { blessed($_) && $_->isa(A) };
					subtype "Me", as &Object,
						init_where { SELF->{me} = caller(2) }
						where { UNIVERSAL::isa($_, SELF->{me}) };
				subtype "Map[K, V]", as &HashRef,
					where {
						my ($K, $V) = ARGS;
						while(my ($k, $v) = each %$_) {
							return "" unless $K->include($k) && $V->include($v);
						}
						return 1;
					};

				my $tuple_args = ArrayRef([Object(['Aion::Type'])]);
				subtype "Tuple[A...]", as &ArrayRef,
					init_where { $tuple_args->validate(scalar ARGS, "Arguments Tuple[A...]") }
					where {
						my $k = 0;
						for my $A (ARGS) {
							return "" if $A->exclude($_->[$k++]);
						}
						$k == @$_
					};
				subtype "CycleTuple[A...]", as &ArrayRef,
					init_where { $tuple_args->validate(scalar ARGS, "Arguments CycleTuple[A...]") }
					where {
						my $k = 0;