package Type::Tiny::Enum;

use 5.008001;
use strict;
use warnings;

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

$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 sorter coderef passed to the constructor"
		if exists $opts{sorter};
	_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 _lockdown {
	my ( $self, $callback ) = @_;
	$callback->( $self->{values}, $self->{unique_values} );
}

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 use_eq        { return $_[0]{use_eq} if exists $_[0]{use_eq}; $_[0]{use_eq} = $_[0]->_build_use_eq }

sub _is_null_constraint { 0 }

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

sub _build_use_eq {
	my $self = shift;
	!Type::Tiny::_USE_XS and @{ $self->unique_values } <= 5;
}

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;
	
	if ( my $xs_encoding = _xs_encoding( $self->unique_values ) ) {
		my $xsub = Type::Tiny::XS::get_subname_for( $xs_encoding );
		return "$xsub\($_[0]\)" if $xsub && !$Type::Tiny::AvoidCallbacks;
	}
	
	my $code;
	if ( $self->use_eq ) {
		use B ();
		my %seen;
		my @vals = grep { not $seen{$_}++ } @{ $self->values };
		if ( @vals == 1 ) {
			$code = sprintf( '(defined %s and !ref %s and %s eq %s)', $_[0], $_[0], $_[0], B::perlstring($vals[0]) );
		}
		else {
			$code = sprintf( '(defined %s and !ref %s and (%s))', $_[0], $_[0], join q{ or } => map { sprintf '(%s eq %s)', $_[0], B::perlstring($_) } @vals );
		}
	}
	else {
		my $regexp = $self->_regexp;
		$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 SYNOPSIS

Using via L<Types::Standard>:

  package Horse {
    use Moo;
    use Types::Standard qw( Str Enum );
    
    has name    => ( is => 'ro', isa => Str );
    has status  => ( is => 'ro', isa => Enum[ 'alive', 'dead' ] );
    
    sub neigh {
      my ( $self ) = @_;
      return if $self->status eq 'dead';
      ...;
    }
  }

Using Type::Tiny::Enum's export feature:

  package Horse {
    use Moo;
    use Types::Standard qw( Str );
    use Type::Tiny::Enum Status => [ 'alive', 'dead' ];
    
    has name    => ( is => 'ro', isa => Str );
    has status  => ( is => 'ro', isa => Status, default => STATUS_ALIVE );
    
    sub neigh {
      my ( $self ) = @_;
      return if $self->status eq STATUS_DEAD;
      ...;
    }
  }

Using Type::Tiny::Enum's object-oriented interface:

  package Horse {
    use Moo;
    use Types::Standard qw( Str );
    use Type::Tiny::Enum;
    
    my $Status = Type::Tiny::Enum->new(
      name   => 'Status',
      values => [ 'alive', 'dead' ],
    );
    
    has name    => ( is => 'ro', isa => Str );
    has status  => ( is => 'ro', isa => $Status, default => $Status->[0] );
    
    sub neigh {
      my ( $self ) = @_;
      return if $self->status eq $Status->[0];
      ...;
    }
  }

=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<sorter>

Sorters passed to the constructor. Instead, enum types can sort values based
on the order the enum was originally defined in.

=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.

=item C<use_eq>

When generating Perl type checking code, Type::Tiny::Enum will traditionally
test incoming strings for being valid using a single regular expression,
unless L<Type::Tiny::XS> is available and a faster XS check is possible.

From version 2.008006 onwards, if L<Type::Tiny::XS> is unavailable, and the
enum is "small" (five possible values or less), Type::Tiny::Enum will instead
generate code like:

  ( $_ eq "foo" or $_ eq "bar" or $_ eq "baz" )

... which benchmarks around 5% to 20% faster than C<< /(?:ba[rz]|foo)/ >>.

However, it is possible to manually indicate whether you prefer it to
generate code using C<eq> or regexps by setting C<use_eq> to a boolean
value in the constructor. (If C<use_eq> is not passed to the constructor
at all, Type::Tiny::Enum will try to guess the most efficient technique.)

If you know that certain values in your enumeration are more common than
others, you can "front load" your enumeration with the most common values
so that C<eq> checks those I<first>. This may allow you to speed up certain
checks.

  has car_colour => (
    is  => 'rw',
    isa => Type::Tiny::Enum->new( use_eq => 1, values => [qw/
      blue
      red
      grey
      white
      black
      green
      yellow
      orange
      purple
      pink
    /] );
  );

=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-2025 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.