path: root/lib/Type/Tiny/Enum.pm

package Type::Tiny::Enum;

use 5.008001;
use strict;
use warnings;

BEGIN {
	$Type::Tiny::Enum::AUTHORITY = 'cpan:TOBYINK';
	$Type::Tiny::Enum::VERSION   = '2.000001';
}

$Type::Tiny::Enum::VERSION =~ tr/_//d;

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

use Exporter::Tiny 1.004001 ();
use Type::Tiny ();
our @ISA = qw( Type::Tiny Exporter::Tiny );

__PACKAGE__->_install_overloads(
	q[@{}] => sub { shift->values },
);

sub _exporter_fail {
	my ( $class, $type_name, $values, $globals ) = @_;
	my $caller = $globals->{into};
	my $type = $class->new(
		name      => $type_name,
		values    => [ @$values ],
		coercion  => 1,
	);
	$INC{'Type/Registry.pm'}
		? 'Type::Registry'->for_class( $caller )->add_type( $type, $type_name )
		: ( $Type::Registry::DELAYED{$caller}{$type_name} = $type )
		unless( ref($caller) or $caller eq '-lexical' or $globals->{'lexical'} );
	return map +( $_->{name} => $_->{code} ), @{ $type->exportables };
}

sub new {
	my $proto = shift;
	
	my %opts = ( @_ == 1 ) ? %{ $_[0] } : @_;
	_croak
		"Enum type constraints cannot have a parent constraint passed to the constructor"
		if exists $opts{parent};
	_croak
		"Enum type constraints cannot have a constraint coderef passed to the constructor"
		if exists $opts{constraint};
	_croak
		"Enum type constraints cannot have a inlining coderef passed to the constructor"
		if exists $opts{inlined};
	_croak "Need to supply list of values" unless exists $opts{values};
	
	no warnings 'uninitialized';
	$opts{values} = [
		map "$_",
		@{ ref $opts{values} eq 'ARRAY' ? $opts{values} : [ $opts{values} ] }
	];
	
	my %tmp;
	undef $tmp{$_} for @{ $opts{values} };
	$opts{unique_values} = [ sort keys %tmp ];
	
	my $xs_encoding = _xs_encoding( $opts{unique_values} );
	if ( defined $xs_encoding ) {
		my $xsub = Type::Tiny::XS::get_coderef_for( $xs_encoding );
		$opts{compiled_type_constraint} = $xsub if $xsub;
	}
	
	if ( defined $opts{coercion} and !ref $opts{coercion} and 1 eq $opts{coercion} )
	{
		delete $opts{coercion};
		$opts{_build_coercion} = sub {
			require Types::Standard;
			my $c = shift;
			my $t = $c->type_constraint;
			$c->add_type_coercions(
				Types::Standard::Str(),
				sub { $t->closest_match( @_ ? $_[0] : $_ ) }
			);
		};
	} #/ if ( defined $opts{coercion...})
	
	return $proto->SUPER::new( %opts );
} #/ sub new

sub new_union {
	my $proto  = shift;
	my %opts   = ( @_ == 1 ) ? %{ $_[0] } : @_;
	my @types  = @{ delete $opts{type_constraints} };
	my @values = map @$_, @types;
	$proto->new( %opts, values => \@values );
}

sub new_intersection {
	my $proto  = shift;
	my %opts   = ( @_ == 1 ) ? %{ $_[0] } : @_;
	my @types  = @{ delete $opts{type_constraints} };
	my %values; ++$values{$_} for map @$_, @types;
	my @values = sort grep $values{$_}==@types, keys %values;
	$proto->new( %opts, values => \@values );
}

sub values        { $_[0]{values} }
sub unique_values { $_[0]{unique_values} }
sub constraint    { $_[0]{constraint} ||= $_[0]->_build_constraint }

sub _is_null_constraint { 0 }

sub _build_display_name {
	my $self = shift;
	sprintf( "Enum[%s]", join q[,], @{ $self->unique_values } );
}

sub is_word_safe {
	my $self = shift;
	return not grep /\W/, @{ $self->unique_values };
}

sub exportables {
	my ( $self, $base_name ) = @_;
	if ( not $self->is_anon ) {
		$base_name ||= $self->name;
	}
	
	my $exportables = $self->SUPER::exportables( $base_name );
	
	if ( $self->is_word_safe ) {
		require Eval::TypeTiny;
		require B;
		for my $value ( @{ $self->unique_values } ) {
			push @$exportables, {
				name => uc( sprintf '%s_%s', $base_name, $value ),
				tags => [ 'constants' ],
				code => Eval::TypeTiny::eval_closure(
					source      => sprintf( 'sub () { %s }', B::perlstring($value) ),
					environment => {},
				),
			};
		}
	}
	
	return $exportables;
}

{
	my $new_xs;
	
	#
	# Note the fallback code for older Type::Tiny::XS cannot be tested as
	# part of the coverage tests because they use the latest Type::Tiny::XS.
	#
	
	sub _xs_encoding {
		my $unique_values = shift;
		
		return undef unless Type::Tiny::_USE_XS;
		
		return undef if @$unique_values > 50;    # RT 121957
		
		$new_xs = eval { Type::Tiny::XS->VERSION( "0.020" ); 1 } ? 1 : 0
			unless defined $new_xs;
		if ( $new_xs ) {
			require B;
			return sprintf(
				"Enum[%s]",
				join( ",", map B::perlstring( $_ ), @$unique_values )
			);
		}
		else {                                   # uncoverable statement
			return undef if grep /\W/, @$unique_values;                    # uncoverable statement
			return sprintf( "Enum[%s]", join( ",", @$unique_values ) );    # uncoverable statement
		}    # uncoverable statement
	} #/ sub _xs_encoding
}

{
	my %cached;
	
	sub _build_constraint {
		my $self = shift;
		
		my $regexp = $self->_regexp;
		return $cached{$regexp} if $cached{$regexp};
		my $coderef = ( $cached{$regexp} = sub { defined and m{\A(?:$regexp)\z} } );
		Scalar::Util::weaken( $cached{$regexp} );
		return $coderef;
	}
}

{
	my %cached;
	
	sub _build_compiled_check {
		my $self   = shift;
		my $regexp = $self->_regexp;
		return $cached{$regexp} if $cached{$regexp};
		my $coderef = ( $cached{$regexp} = $self->SUPER::_build_compiled_check( @_ ) );
		Scalar::Util::weaken( $cached{$regexp} );
		return $coderef;
	}
}

sub _regexp {
	my $self = shift;
	$self->{_regexp} ||= 'Type::Tiny::Enum::_Trie'->handle( $self->unique_values );
}

sub as_regexp {
	my $self = shift;
	
	my $flags = @_ ? $_[0] : '';
	unless ( defined $flags and $flags =~ /^[i]*$/ ) {
		_croak(
			"Unknown regexp flags: '$flags'; only 'i' currently accepted; stopped" );
	}
	
	my $regexp = $self->_regexp;
	$flags ? qr/\A(?:$regexp)\z/i : qr/\A(?:$regexp)\z/;
} #/ sub as_regexp

sub can_be_inlined {
	!!1;
}

sub inline_check {
	my $self = shift;
	
	my $xsub;
	if ( my $xs_encoding = _xs_encoding( $self->unique_values ) ) {
		$xsub = Type::Tiny::XS::get_subname_for( $xs_encoding );
		return "$xsub\($_[0]\)" if $xsub && !$Type::Tiny::AvoidCallbacks;
	}
	
	my $regexp = $self->_regexp;
	my $code =
		$_[0] eq '$_'
		? "(defined and !ref and m{\\A(?:$regexp)\\z})"
		: "(defined($_[0]) and !ref($_[0]) and $_[0] =~ m{\\A(?:$regexp)\\z})";
		
	return "do { $Type::Tiny::SafePackage $code }"
		if $Type::Tiny::AvoidCallbacks;
	return $code;
} #/ sub inline_check

sub _instantiate_moose_type {
	my $self = shift;
	my %opts = @_;
	delete $opts{parent};
	delete $opts{constraint};
	delete $opts{inlined};
	require Moose::Meta::TypeConstraint::Enum;
	return "Moose::Meta::TypeConstraint::Enum"
		->new( %opts, values => $self->values );
} #/ sub _instantiate_moose_type

sub has_parent {
	!!1;
}

sub parent {
	require Types::Standard;
	Types::Standard::Str();
}

sub validate_explain {
	my $self = shift;
	my ( $value, $varname ) = @_;
	$varname = '$_' unless defined $varname;
	
	return undef if $self->check( $value );
	
	require Type::Utils;
	!defined( $value )
		? [
		sprintf(
			'"%s" requires that the value is defined',
			$self,
		),
		]
		: @$self < 13 ? [
		sprintf(
			'"%s" requires that the value is equal to %s',
			$self,
			Type::Utils::english_list( \"or", map B::perlstring( $_ ), @$self ),
		),
		]
		: [
		sprintf(
			'"%s" requires that the value is one of an enumerated list of strings',
			$self,
		),
		];
} #/ sub validate_explain

sub has_sorter {
	!!1;
}

sub _enum_order_hash {
	my $self = shift;
	my %hash;
	my $i = 0;
	for my $value ( @{ $self->values } ) {
		next if exists $hash{$value};
		$hash{$value} = $i++;
	}
	return %hash;
} #/ sub _enum_order_hash

sub sorter {
	my $self = shift;
	my %hash = $self->_enum_order_hash;
	return [
		sub { $_[0] <=> $_[1] },
		sub { exists( $hash{ $_[0] } ) ? $hash{ $_[0] } : 2_100_000_000 },
	];
}

my $canon;

sub closest_match {
	require Types::Standard;
	
	my ( $self, $given ) = ( shift, @_ );
	
	return unless Types::Standard::is_Str $given;
	
	return $given if $self->check( $given );
	
	$canon ||= eval(
		$] lt '5.016'
		? q< sub { ( my $var = lc($_[0]) ) =~ s/(^\s+)|(\s+$)//g; $var } >
		: q< sub { CORE::fc($_[0]) =~ s/(^\s+)|(\s+$)//gr; } >
	);
	
	$self->{_lookups} ||= do {
		my %lookups;
		for ( @{ $self->values } ) {
			my $key = $canon->( $_ );
			next if exists $lookups{$key};
			$lookups{$key} = $_;
		}
		\%lookups;
	};
	
	my $cgiven = $canon->( $given );
	return $self->{_lookups}{$cgiven}
		if $self->{_lookups}{$cgiven};
		
	my $best;
	VALUE: for my $possible ( @{ $self->values } ) {
		my $stem = substr( $possible, 0, length $cgiven );
		if ( $cgiven eq $canon->( $stem ) ) {
			if ( defined( $best ) and length( $best ) >= length( $possible ) ) {
				next VALUE;
			}
			$best = $possible;
		}
	}
	
	return $best if defined $best;
	
	return $self->values->[$given]
		if Types::Standard::is_Int $given;
		
	return $given;
} #/ sub closest_match

push @Type::Tiny::CMP, sub {
	my $A = shift->find_constraining_type;
	my $B = shift->find_constraining_type;
	return Type::Tiny::CMP_UNKNOWN
		unless $A->isa( __PACKAGE__ ) && $B->isa( __PACKAGE__ );
		
	my %seen;
	for my $word ( @{ $A->unique_values } ) {
		$seen{$word} += 1;
	}
	for my $word ( @{ $B->unique_values } ) {
		$seen{$word} += 2;
	}
	
	my $values = join( '', CORE::values %seen );
	if ( $values =~ /^3*$/ ) {
		return Type::Tiny::CMP_EQUIVALENT;
	}
	elsif ( $values !~ /2/ ) {
		return Type::Tiny::CMP_SUPERTYPE;
	}
	elsif ( $values !~ /1/ ) {
		return Type::Tiny::CMP_SUBTYPE;
	}
	
	return Type::Tiny::CMP_UNKNOWN;
};

package    # stolen from Regexp::Trie
	Type::Tiny::Enum::_Trie;
sub new { bless {} => shift }

sub add {
	my $self = shift;
	my $str  = shift;
	my $ref  = $self;
	for my $char ( split //, $str ) {
		$ref->{$char} ||= {};
		$ref = $ref->{$char};
	}
	$ref->{''} = 1;    # { '' => 1 } as terminator
	$self;
} #/ sub add

sub _regexp {
	my $self = shift;
	return if $self->{''} and scalar keys %$self == 1;    # terminator
	my ( @alt, @cc );
	my $q = 0;
	for my $char ( sort keys %$self ) {
		my $qchar = quotemeta $char;
		if ( ref $self->{$char} ) {
			if ( defined( my $recurse = _regexp( $self->{$char} ) ) ) {
				push @alt, $qchar . $recurse;
			}
			else {
				push @cc, $qchar;
			}
		}
		else {
			$q = 1;
		}
	} #/ for my $char ( sort keys...)
	my $cconly = !@alt;
	@cc and push @alt, @cc == 1 ? $cc[0] : '[' . join( '', @cc ) . ']';
	my $result = @alt == 1 ? $alt[0] : '(?:' . join( '|', @alt ) . ')';
	$q and $result = $cconly ? "$result?" : "(?:$result)?";
	return $result;
} #/ sub _regexp

sub handle {
	my $class = shift;
	my ( $vals ) = @_;
	return '(?!)' unless @$vals;
	my $self = $class->new;
	$self->add( $_ ) for @$vals;
	$self->_regexp;
}

1;

__END__

=pod

=encoding utf-8

=head1 NAME

Type::Tiny::Enum - string enum type constraints

=head1 STATUS

This module is covered by the
L<Type-Tiny stability policy|Type::Tiny::Manual::Policies/"STABILITY">.

=head1 DESCRIPTION

Enum type constraints.

This package inherits from L<Type::Tiny>; see that for most documentation.
Major differences are listed below:

=head2 Constructors

The C<new> constructor from L<Type::Tiny> still works, of course. But there
is also:

=over

=item C<< new_union( type_constraints => \@enums, %opts ) >>

Creates a new enum type constraint which is the union of existing enum
type constraints.

=item C<< new_intersection( type_constraints => \@enums, %opts ) >>

Creates a new enum type constraint which is the intersection of existing enum
type constraints.

=back

=head2 Attributes

=over

=item C<values>

Arrayref of allowable value strings. Non-string values (e.g. objects with
overloading) will be stringified in the constructor.

=item C<constraint>

Unlike Type::Tiny, you I<cannot> pass a constraint coderef to the constructor.
Instead rely on the default.

=item C<inlined>

Unlike Type::Tiny, you I<cannot> pass an inlining coderef to the constructor.
Instead rely on the default.

=item C<parent>

Parent is always B<Types::Standard::Str>, and cannot be passed to the
constructor.

=item C<unique_values>

The list of C<values> but sorted and with duplicates removed. This cannot
be passed to the constructor.

=item C<coercion>

If C<< coercion => 1 >> is passed to the constructor, the type will have a
coercion using the C<closest_match> method.

=back

=head2 Methods

=over

=item C<as_regexp>

Returns the enum as a regexp which strings can be checked against. If you're
checking I<< a lot >> of strings, then using this regexp might be faster than
checking each string against 

  my $enum  = Type::Tiny::Enum->new(...);
  my $check = $enum->compiled_check;
  my $re    = $enum->as_regexp;
  
  # fast
  my @valid_tokens = grep $enum->check($_), @all_tokens;
  
  # faster
  my @valid_tokens = grep $check->($_), @all_tokens;
  
  # fastest
  my @valid_tokens = grep /$re/, @all_tokens;

You can get a case-insensitive regexp using C<< $enum->as_regexp('i') >>.

=item C<closest_match>

Returns the closest match in the enum for a string.

  my $enum = Type::Tiny::Enum->new(
    values => [ qw( foo bar baz quux ) ],
  );
  
  say $enum->closest_match("FO");   # ==> foo

It will try to find an exact match first, fall back to a case-insensitive
match, if it still can't find one, will try to find a head substring match,
and finally, if given an integer, will use that as an index.

  my $enum = Type::Tiny::Enum->new(
    values => [ qw( foo bar baz quux ) ],
  );
  
  say $enum->closest_match(  0 );  # ==> foo
  say $enum->closest_match(  1 );  # ==> bar
  say $enum->closest_match(  2 );  # ==> baz
  say $enum->closest_match( -1 );  # ==> quux

=item C<< is_word_safe >>

Returns true if none of the values in the enumeration contain a non-word
character. Word characters include letters, numbers, and underscores, but
not most punctuation or whitespace.

=back

=head2 Exports

Type::Tiny::Enum can be used as an exporter.

  use Type::Tiny::Enum Status => [ 'dead', 'alive' ];

This will export the following functions into your namespace:

=over

=item C<< Status >>

=item C<< is_Status( $value ) >>

=item C<< assert_Status( $value ) >>

=item C<< to_Status( $value ) >>

=item C<< STATUS_DEAD >>

=item C<< STATUS_ALIVE >>

=back

Multiple enumerations can be exported at once:

  use Type::Tiny::Enum (
    Status    => [ 'dead', 'alive' ],
    TaxStatus => [ 'paid', 'pending' ],
  );

=head2 Overloading

=over

=item *

Arrayrefification calls C<values>.

=back

=head1 BUGS

Please report any bugs to
L<https://github.com/tobyink/p5-type-tiny/issues>.

=head1 SEE ALSO

L<Type::Tiny::Manual>.

L<Type::Tiny>.

L<Moose::Meta::TypeConstraint::Enum>.

=head1 AUTHOR

Toby Inkster E<lt>tobyink@cpan.orgE<gt>.

=head1 COPYRIGHT AND LICENCE

This software is copyright (c) 2013-2014, 2017-2022 by Toby Inkster.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=head1 DISCLAIMER OF WARRANTIES

THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.