File Coverage

blib/lib/Type/Utils.pm

Criterion	Covered	Total	%
statement	350	385	90.9
branch	143	196	72.9
condition	35	75	46.6
subroutine	48	49	97.9
pod	24	24	100.0
total	600	729	82.3

package Type::Utils;

use 5.008001;
use strict;
use warnings;

BEGIN {
	$Type::Utils::AUTHORITY = 'cpan:TOBYINK';
	$Type::Utils::VERSION   = '2.010001';
}

$Type::Utils::VERSION =~ tr/_//d;

sub _croak ($;@) { require Error::TypeTiny; goto \&Error::TypeTiny::croak }

use Scalar::Util qw< blessed >;
use Type::Library;
use Type::Tiny;
use Types::TypeTiny qw< TypeTiny is_TypeTiny to_TypeTiny HashLike StringLike >;

our @EXPORT = qw<
	declare as where message inline_as
	class_type role_type duck_type union intersection enum
	coerce from via
	declare_coercion to_type
>;
our @EXPORT_OK = (
	@EXPORT,
	qw<
		extends type subtype
		match_on_type compile_match_on_type
		dwim_type english_list
		classifier assert
		>,
	"is",
);
our %EXPORT_TAGS = (
	default => [@EXPORT],
	all     => [@EXPORT_OK],
);
pop @{ $EXPORT_TAGS{all} };    # remove 'is'

require Exporter::Tiny;
our @ISA = 'Exporter::Tiny';

sub extends {
	_croak "Not a type library" unless caller->isa( "Type::Library" );
	my $caller = caller->meta;

	foreach my $lib ( @_ ) {
		eval "use $lib; 1" or _croak "Could not load library '$lib': $@";

		if ( $lib->isa( "Type::Library" ) or $lib eq 'Types::TypeTiny' ) {
			$caller->add_type( $lib->get_type( $_ ) ) for sort $lib->meta->type_names;
			$caller->add_coercion( $lib->get_coercion( $_ ) )
				for sort $lib->meta->coercion_names;
		}
		elsif ( $lib->isa( 'MooseX::Types::Base' ) ) {
			require Moose::Util::TypeConstraints;
			my $types = $lib->type_storage;
			for my $name ( sort keys %$types ) {
				my $moose =
					Moose::Util::TypeConstraints::find_type_constraint( $types->{$name} );
				my $tt = Types::TypeTiny::to_TypeTiny( $moose );
				my $c  = $moose->has_coercion && @{ $moose->coercion->type_coercion_map || [] };
				$caller->add_type(
					$tt->create_child_type(
						library => $caller, name => $name, coercion => $c ? 1 : 0
					)
				);
			} #/ for my $name ( sort keys...)
		} #/ elsif ( $lib->isa( 'MooseX::Types::Base'...))
		elsif ( $lib->isa( 'MouseX::Types::Base' ) ) {
			require Mouse::Util::TypeConstraints;
			my $types = $lib->type_storage;
			for my $name ( sort keys %$types ) {
				my $mouse =
					Mouse::Util::TypeConstraints::find_type_constraint( $types->{$name} );
				my $tt = Types::TypeTiny::to_TypeTiny( $mouse );
				$caller->add_type(
					$tt->create_child_type(
						library => $caller, name => $name, coercion => $mouse->has_coercion ? 1 : 0
					)
				);
			} #/ for my $name ( sort keys...)
		} #/ elsif ( $lib->isa( 'MouseX::Types::Base'...))
		elsif ( $lib->isa( 'Specio::Exporter' ) ) {
			my $types = $lib->Specio::Registry::exportable_types_for_package;
			for my $name ( sort keys %$types ) {
				my $specio = $types->{$name};
				my $tt     = Types::TypeTiny::to_TypeTiny( $specio );
				$caller->add_type(
					$tt->create_child_type( library => $caller, name => $name )
				);
			}
		}
		elsif ( $lib->isa( 'Exporter' )
		and my $types = do { no strict 'refs'; ${"$lib\::EXPORT_TAGS"}{'types'} } ) {
			for my $name ( @$types ) {
				my $obj = $lib->$name;
				my $tt  = Types::TypeTiny::to_TypeTiny( $obj );
				$caller->add_type(
					$tt->create_child_type( library => $caller, name => $name )
				);
			}
		}
		else {
			_croak( "'$lib' is not a type constraint library" );
		}
	} #/ foreach my $lib ( @_ )
} #/ sub extends

sub declare {
	my %opts;
	if ( @_ % 2 == 0 ) {
		%opts = @_;
		if ( @_ == 2 and $_[0] =~ /^_*[A-Z]/ and $_[1] =~ /^[0-9]+$/ ) {
			require Carp;
			Carp::carp( "Possible missing comma after 'declare $_[0]'" );
		}
	}
	else {
		( my ( $name ), %opts ) = @_;
		_croak "Cannot provide two names for type" if exists $opts{name};
		$opts{name} = $name;
	}

	my $caller = caller( $opts{_caller_level} || 0 );
	$opts{library} = $caller;

	if ( defined $opts{parent} ) {
		$opts{parent} = to_TypeTiny( $opts{parent} );

		unless ( is_TypeTiny( $opts{parent} ) ) {
			$caller->isa( "Type::Library" )
				or _croak(
				"Parent type cannot be a %s",
				ref( $opts{parent} ) || 'non-reference scalar'
				);
			$opts{parent} = $caller->meta->get_type( $opts{parent} )
				or _croak( "Could not find parent type" );
		}
	} #/ if ( defined $opts{parent...})

	my $type;
	if ( defined $opts{parent} ) {
		$type = delete( $opts{parent} )->create_child_type( %opts );
	}
	else {
		my $bless = delete( $opts{bless} ) || "Type::Tiny";
		eval "require $bless";
		$type = $bless->new( %opts );
	}

	if ( not $type->is_anon ) {

		$caller->meta->add_type( $type )
			if $caller->isa( 'Type::Library' );

		$INC{'Type/Registry.pm'}
			? 'Type::Registry'->for_class( $caller )->add_type( $type, $opts{name} )
			: ( $Type::Registry::DELAYED{$caller}{$opts{name}} = $type );
	}

	return $type;
} #/ sub declare

*subtype = \&declare;
*type    = \&declare;

sub as (@) {
	parent => @_;
}

sub where (&;@) {
	constraint => @_;
}

sub message (&;@) {
	message => @_;
}

sub inline_as (&;@) {
	inlined => @_;
}

sub class_type {
	my $name = ref( $_[0] ) eq 'HASH' ? undef : shift;
	my %opts = %{ shift or {} };

	if ( defined $name ) {
		$opts{name}  = $name unless exists $opts{name};
		$opts{class} = $name unless exists $opts{class};

		$opts{name} =~ s/:://g;
	}

	$opts{bless} = "Type::Tiny::Class";

	{ no warnings "numeric"; $opts{_caller_level}++ }
	declare( %opts );
} #/ sub class_type

sub role_type {
	my $name = ref( $_[0] ) eq 'HASH' ? undef : shift;
	my %opts = %{ shift or {} };

	if ( defined $name ) {
		$opts{name} = $name unless exists $opts{name};
		$opts{role} = $name unless exists $opts{role};

		$opts{name} =~ s/:://g;
	}

	$opts{bless} = "Type::Tiny::Role";

	{ no warnings "numeric"; $opts{_caller_level}++ }
	declare( %opts );
} #/ sub role_type

sub duck_type {
	my $name    = ref( $_[0] ) eq 'ARRAY' ? undef : shift;
	my @methods = @{ shift or [] };

	my %opts;
	$opts{name}    = $name if defined $name;
	$opts{methods} = \@methods;

	$opts{bless} = "Type::Tiny::Duck";

	{ no warnings "numeric"; $opts{_caller_level}++ }
	declare( %opts );
} #/ sub duck_type

sub enum {
	my $name   = ref( $_[0] ) eq 'ARRAY' ? undef : shift;
	my @values = @{ shift or [] };

	my %opts;
	$opts{name}   = $name if defined $name;
	$opts{values} = \@values;

	$opts{bless} = "Type::Tiny::Enum";

	{ no warnings "numeric"; $opts{_caller_level}++ }
	declare( %opts );
} #/ sub enum

sub union {
	my $name = ref( $_[0] ) eq 'ARRAY' ? undef : shift;
	my @tcs  = @{ shift or [] };

	my %opts;
	$opts{name}             = $name if defined $name;
	$opts{type_constraints} = \@tcs;

	$opts{bless} = "Type::Tiny::Union";

	{ no warnings "numeric"; $opts{_caller_level}++ }
	declare( %opts );
} #/ sub union

sub intersection {
	my $name = ref( $_[0] ) eq 'ARRAY' ? undef : shift;
	my @tcs  = @{ shift or [] };

	my %opts;
	$opts{name}             = $name if defined $name;
	$opts{type_constraints} = \@tcs;

	$opts{bless} = "Type::Tiny::Intersection";

	{ no warnings "numeric"; $opts{_caller_level}++ }
	declare( %opts );
} #/ sub intersection

sub declare_coercion {
	my %opts;
	$opts{name} = shift if !ref( $_[0] );

	# I don't like this; it is a hack
	if ( ref( $_[0] ) eq 'Type::Tiny::_DeclaredType' ) {
		$opts{name} = '' . shift;
	}

	while ( Types::TypeTiny::is_HashLike( $_[0] ) and not is_TypeTiny( $_[0] ) ) {
		%opts = ( %opts, %{ +shift } );
	}

	my $caller = caller( $opts{_caller_level} || 0 );
	$opts{library} = $caller;

	my $bless = delete( $opts{bless} ) || "Type::Coercion";
	eval "require $bless";
	my $c = $bless->new( %opts );

	my @C;

	if ( $caller->isa( "Type::Library" ) ) {
		my $meta = $caller->meta;
		$meta->add_coercion( $c ) unless $c->is_anon;
		while ( @_ ) {
			push @C,
				map { ref( $_ ) ? to_TypeTiny( $_ ) : $meta->get_type( $_ ) || $_ } shift;
			push @C, shift;
		}
	}
	else {
		@C = @_;
	}

	$c->add_type_coercions( @C );

	return $c->freeze;
} #/ sub declare_coercion

sub coerce {
	if ( ( scalar caller )->isa( "Type::Library" ) ) {
		my $meta = ( scalar caller )->meta;
		my ( $type ) =
			map { ref( $_ ) ? to_TypeTiny( $_ ) : $meta->get_type( $_ ) || $_ } shift;
		my @opts;
		while ( @_ ) {
			push @opts,
				map { ref( $_ ) ? to_TypeTiny( $_ ) : $meta->get_type( $_ ) || $_ } shift;
			push @opts, shift;
		}
		return $type->coercion->add_type_coercions( @opts );
	} #/ if ( ( scalar caller )...)

	my ( $type, @opts ) = @_;
	$type = to_TypeTiny( $type );
	return $type->coercion->add_type_coercions( @opts );
} #/ sub coerce

sub from (@) {
	return @_;
}

sub to_type (@) {
	my $type = shift;
	unless ( is_TypeTiny( $type ) ) {
		caller->isa( "Type::Library" )
			or _croak "Target type cannot be a string";
		$type = caller->meta->get_type( $type )
			or _croak "Could not find target type";
	}
	return +{ type_constraint => $type }, @_;
} #/ sub to_type (@)

sub via (&;@) {
	return @_;
}

sub match_on_type {
	my $value = shift;

	while ( @_ ) {
		my $code;
		if ( @_ == 1 ) {
			$code = shift;
		}
		else {
			( my ( $type ), $code ) = splice( @_, 0, 2 );
			Types::TypeTiny::assert_TypeTiny( $type )->check( $value ) or next;
		}

		if ( Types::TypeTiny::is_StringLike( $code ) ) {
			local $_ = $value;
			if ( wantarray ) {
				my @r = eval "$code";
				die $@ if $@;
				return @r;
			}
			if ( defined wantarray ) {
				my $r = eval "$code";
				die $@ if $@;
				return $r;
			}
			eval "$code";
			die $@ if $@;
			return;
		} #/ if ( Types::TypeTiny::is_StringLike...)
		else {
			Types::TypeTiny::assert_CodeLike( $code );
			local $_ = $value;
			return $code->( $value );
		}
	} #/ while ( @_ )

	_croak( "No cases matched for %s", Type::Tiny::_dd( $value ) );
} #/ sub match_on_type

sub compile_match_on_type {
	require Eval::TypeTiny::CodeAccumulator;
	my $coderef = 'Eval::TypeTiny::CodeAccumulator'->new(
		description => 'compiled match',
	);
	$coderef->add_line( 'sub {' );
	$coderef->increase_indent;
	$coderef->add_line( 'local $_ = $_[0];' );

	my $els = '';

	while ( @_ ) {
		my ( $type, $code );
		if ( @_ == 1 ) {
			require Types::Standard;
			( $type, $code ) = ( Types::Standard::Any(), shift );
		}
		else {
			( $type, $code ) = splice( @_, 0, 2 );
			Types::TypeTiny::assert_TypeTiny( $type );
		}

		if ( $type->can_be_inlined ) {
			$coderef->add_line( sprintf(
				'%sif ( %s ) {',
				$els,
				$type->inline_check( '$_' ),
			) );
		}
		else {
			my $varname = $coderef->add_variable( '$type', \$type );
			$coderef->add_line( sprintf(
				'%sif ( %s->check($_) ) {',
				$els,
				$varname,
			) );
		}
		$coderef->increase_indent;

		$els = 'els';

		if ( Types::TypeTiny::is_StringLike( $code ) ) {
			$coderef->add_line( $code );
		}
		else {
			Types::TypeTiny::assert_CodeLike( $code );
			my $varname = $coderef->add_variable( '$action', \$code );
			$coderef->add_line( sprintf(
				'%s->( @_ )',
				$varname,
			) );
		}
		$coderef->decrease_indent;
		$coderef->add_line( '}' );
	} #/ while ( @_ )

	$coderef->add_line( 'else {' );
	$coderef->increase_indent;
	$coderef->add_line( 'Type::Utils::_croak( "No cases matched for %s", Type::Tiny::_dd( $_ ) );' );
	$coderef->decrease_indent;
	$coderef->add_line( '}' );

	$coderef->decrease_indent;
	$coderef->add_line( '}' );

	return $coderef->compile;
} #/ sub compile_match_on_type

sub classifier {
	my $i;
	compile_match_on_type(
		+(
			map {
				my $type = $_->[0];
				$type => sub { $type };
				}
				sort { $b->[1] <=> $a->[1] or $a->[2] <=> $b->[2] }
				map [ $_, scalar( my @parents = $_->parents ), ++$i ],
			@_
		),
		q[ undef ],
	);
} #/ sub classifier

{
	package    #hide
		Type::Registry::DWIM;

	our @ISA = qw(Type::Registry);

	sub foreign_lookup {
		my $self = shift;
		my $r    = $self->SUPER::foreign_lookup( @_ );
		return $r if $r;

		if ( my $assume = $self->{"~~assume"}
			and $_[0] =~ /[A-Z_a-z][0-9A-Z_a-z]*(?:::[0-9A-Z_a-z]+)*/ )
		{
			my @methods = ref( $assume ) ? @$assume : $assume;

			for my $method ( @methods ) {
				$r = $self->$method( @_ );
				return $r if $r;
			}
		} #/ if ( my $assume = $self...)

		return;
	} #/ sub foreign_lookup

	sub lookup_via_moose {
		my $self = shift;

		if ( $INC{'Moose/Meta/TypeConstraint.pm'} ) {
			require Moose::Util::TypeConstraints;
			require Types::TypeTiny;
			my $r = Moose::Util::TypeConstraints::find_type_constraint( $_[0] );
			return Types::TypeTiny::to_TypeTiny( $r ) if defined $r;
		}

		return;
	} #/ sub lookup_via_moose

	sub lookup_via_mouse {
		my $self = shift;

		if ( $INC{'Mouse.pm'} ) {
			require Mouse::Util::TypeConstraints;
			require Types::TypeTiny;
			my $r = Mouse::Util::TypeConstraints::find_type_constraint( $_[0] );
			return Types::TypeTiny::to_TypeTiny( $r ) if defined $r;
		}

		return;
	} #/ sub lookup_via_mouse

	sub simple_lookup {
		my $self = shift;
		my $r;

		# If the lookup is chained to a class, then the class' own
		# type registry gets first refusal.
		#
		if ( defined $self->{"~~chained"} ) {
			my $chained = "Type::Registry"->for_class( $self->{"~~chained"} );
			$r = eval { $chained->simple_lookup( @_ ) } unless $self == $chained;
			return $r if defined $r;
		}

		# Fall back to types in Types::Standard.
		require Types::Standard;
		return 'Types::Standard'->get_type( $_[0] )
			if 'Types::Standard'->has_type( $_[0] );

		# Only continue any further if we've been called from Type::Parser.
		return unless $_[1];

		my $meta;
		if ( defined $self->{"~~chained"} ) {
			$meta ||= Moose::Util::find_meta( $self->{"~~chained"} ) if $INC{'Moose/Util.pm'};
			$meta ||= Mouse::Util::find_meta( $self->{"~~chained"} ) if $INC{'Mouse.pm'};
		}

		if ( $meta and $meta->isa( 'Class::MOP::Module' ) ) {
			$r = $self->lookup_via_moose( @_ );
			return $r if $r;
		}

		elsif ( $meta and $meta->isa( 'Mouse::Meta::Module' ) ) {
			$r = $self->lookup_via_mouse( @_ );
			return $r if $r;
		}

		return $self->foreign_lookup( @_ );
	} #/ sub simple_lookup
}

our $dwimmer;

sub dwim_type {
	my ( $string, %opts ) = @_;
	$opts{for} = caller unless defined $opts{for};

	$dwimmer ||= do {
		require Type::Registry;
		'Type::Registry::DWIM'->new;
	};

	local $dwimmer->{'~~chained'} = $opts{for};
	local $dwimmer->{'~~assume'}  = $opts{fallback} || [
		qw/ lookup_via_moose lookup_via_mouse /,
		$opts{does} ? 'make_role_type' : 'make_class_type',
	];

	local $@ = undef;
	my $type;
	unless ( eval { $type = $dwimmer->lookup( $string ); 1 } ) {
		my $e = $@;
		die( $e ) unless $e =~ /not a known type constraint/;
	}

	$type;
} #/ sub dwim_type

my $TEMPLATE = <<'SUBTEMPLATE';
sub SUBNAME
{
	require Types::TypeTiny;
	no warnings 'uninitialized';

	my ($type, $value) = @_;
	my $caller = caller;

	my $uniq = Types::TypeTiny::is_TypeTiny($type) ? $type->{uniq} : "$type";

	if (not Types::TypeTiny::is_TypeTiny $type) {
		my $orig = $type;

		$type = $is_cache{$caller}{$uniq} || do {
			Types::TypeTiny::is_StringLike($type)
				? eval { dwim_type("$type", for => $caller) }
				: undef;
		};

		if (blessed $type) {
			$is_cache{$caller}{$uniq} ||= $type;
		}
		else {
			my $thing = Type::Tiny::_dd($orig);
			substr($thing, 0, 1) = lc substr($thing, 0, 1);
			require Carp;
			FAILURE
		}
	}

	my $check = ( $is_cache_coderef{$caller}{$uniq} ||= $type->compiled_check );

	BODY
}
SUBTEMPLATE

my %is_cache;
my %is_cache_coderef;

{
	my $code = $TEMPLATE;
	$code =~ s/SUBNAME/is/g;
	$code =~
		s/FAILURE/Carp::carp("Expected type, but got \$thing; returning false"); return undef;/g;
	$code =~ s/BODY/0+!! \$check->(\$value)/;
	eval $code;
}

{
	my $code = $TEMPLATE;
	$code =~ s/SUBNAME/assert/g;
	$code =~
		s/FAILURE/Carp::croak("Expected type, but got \$thing; stopping"); return undef;/g;
	$code =~
		s/BODY/\$check->(\$value) ? \$value : \$type->_failed_check("\$type", \$value)/;
	eval $code;
}

sub english_list {
	my $conjunction = ref( $_[0] ) eq 'SCALAR' ? ${ +shift } : 'and';
	my @items       = sort @_;

	return $items[0]                          if @items == 1;
	return "$items[0] $conjunction $items[1]" if @items == 2;

	my $tail = pop @items;
	join( ', ', @items, "$conjunction $tail" );
} #/ sub english_list

1;

__END__