use Moose::Deprecated;
use Moose::Meta::TypeConstraint;
use Moose::Meta::TypeConstraint::Union;
+use Moose::Meta::TypeConstraint::Intersection;
use Moose::Meta::TypeConstraint::Parameterized;
use Moose::Meta::TypeConstraint::Parameterizable;
use Moose::Meta::TypeConstraint::Class;
use Moose::Meta::TypeConstraint::DuckType;
use Moose::Meta::TypeCoercion;
use Moose::Meta::TypeCoercion::Union;
+use Moose::Meta::TypeCoercion::Intersection;
use Moose::Meta::TypeConstraint::Registry;
Moose::Exporter->setup_import_methods(
type subtype class_type role_type maybe_type duck_type
as where message optimize_as inline_as
coerce from via
- enum
+ enum union
find_type_constraint
register_type_constraint
match_on_type )
}
sub create_type_constraint_union {
+ _create_type_constraint_union(\@_);
+}
+
+sub create_named_type_constraint_union {
+ my $name = shift;
+ _create_type_constraint_union($name, \@_);
+}
+
+sub _create_type_constraint_union {
+ my $name;
+ $name = shift if @_ > 1;
+ my @tcs = @{ shift() };
+
my @type_constraint_names;
- if ( scalar @_ == 1 && _detect_type_constraint_union( $_[0] ) ) {
- @type_constraint_names = _parse_type_constraint_union( $_[0] );
+ if ( scalar @tcs == 1 && _detect_type_constraint_union( $tcs[0] ) ) {
+ @type_constraint_names = _parse_type_constraint_union( $tcs[0] );
}
else {
- @type_constraint_names = @_;
+ @type_constraint_names = @tcs;
}
( scalar @type_constraint_names >= 2 )
"Could not locate type constraint ($_) for the union");
} @type_constraint_names;
- return Moose::Meta::TypeConstraint::Union->new(
- type_constraints => \@type_constraints );
+ my %options = (
+ type_constraints => \@type_constraints
+ );
+ $options{name} = $name if defined $name;
+
+ return Moose::Meta::TypeConstraint::Union->new(%options);
+}
+
+sub create_type_constraint_intersection {
+ my @type_constraint_names;
+
+ if (scalar @_ == 1 && _detect_type_constraint_intersection($_[0])) {
+ @type_constraint_names = _parse_type_constraint_intersection($_[0]);
+ }
+ else {
+ @type_constraint_names = @_;
+ }
+
+ (scalar @type_constraint_names >= 2)
+ || __PACKAGE__->_throw_error("You must pass in at least 2 type names to make an intersection");
+
+ my @type_constraints = map {
+ find_or_parse_type_constraint($_) ||
+ __PACKAGE__->_throw_error("Could not locate type constraint ($_) for the intersection");
+ } @type_constraint_names;
+
+ return Moose::Meta::TypeConstraint::Intersection->new(
+ type_constraints => \@type_constraints
+ );
}
sub create_parameterized_type_constraint {
if ( $constraint = find_type_constraint($type_constraint_name) ) {
return $constraint;
}
- elsif ( _detect_type_constraint_union($type_constraint_name) ) {
+ elsif (_detect_type_constraint_intersection($type_constraint_name)) {
+ $constraint = create_type_constraint_intersection($type_constraint_name);
+ }
+ elsif (_detect_type_constraint_union($type_constraint_name)) {
$constraint = create_type_constraint_union($type_constraint_name);
}
elsif ( _detect_parameterized_type_constraint($type_constraint_name) ) {
# type constructors
sub type {
-
- # back-compat version, called without sugar
- if ( !any { ( reftype($_) || '' ) eq 'HASH' } @_ ) {
- Moose::Deprecated::deprecated(
- feature => 'type without sugar',
- message =>
- 'Calling type() with a simple list of parameters is deprecated. This will be an error in Moose 2.0200.'
- );
-
- return _create_type_constraint( $_[0], undef, $_[1] );
- }
-
my $name = shift;
my %p = map { %{$_} } @_;
}
sub subtype {
-
- # crazy back-compat code for being called without sugar ...
- #
- # subtype 'Parent', sub { where };
- if ( scalar @_ == 2 && ( reftype( $_[1] ) || '' ) eq 'CODE' ) {
- Moose::Deprecated::deprecated(
- feature => 'subtype without sugar',
- message =>
- 'Calling subtype() with a simple list of parameters is deprecated. This will be an error in Moose 2.0200.'
- );
-
- return _create_type_constraint( undef, @_ );
- }
-
- # subtype 'Parent', sub { where }, sub { message };
- # subtype 'Parent', sub { where }, sub { message }, sub { optimized };
- if ( scalar @_ >= 3 && all { ( reftype($_) || '' ) eq 'CODE' }
- @_[ 1 .. $#_ ] ) {
- Moose::Deprecated::deprecated(
- feature => 'subtype without sugar',
- message =>
- 'Calling subtype() with a simple list of parameters is deprecated. This will be an error in Moose 2.0200.'
- );
-
- return _create_type_constraint( undef, @_ );
- }
-
- # subtype 'Name', 'Parent', ...
- if ( scalar @_ >= 2 && all { !ref } @_[ 0, 1 ] ) {
- Moose::Deprecated::deprecated(
- feature => 'subtype without sugar',
- message =>
- 'Calling subtype() with a simple list of parameters is deprecated. This will be an error in Moose 2.0200.'
- );
-
- return _create_type_constraint(@_);
- }
-
if ( @_ == 1 && !ref $_[0] ) {
__PACKAGE__->_throw_error(
'A subtype cannot consist solely of a name, it must have a parent'
);
}
+sub union {
+ my ( $type_name, @constraints ) = @_;
+ if ( ref $type_name eq 'ARRAY' ) {
+ @constraints == 0
+ || __PACKAGE__->_throw_error("union called with an array reference and additional arguments.");
+ @constraints = @$type_name;
+ $type_name = undef;
+ }
+ if ( @constraints == 1 && ref $constraints[0] eq 'ARRAY' ) {
+ @constraints = @{ $constraints[0] };
+ }
+ if ( defined $type_name ) {
+ return register_type_constraint(
+ create_named_type_constraint_union( $type_name, @constraints )
+ );
+ }
+ return create_type_constraint_union( @constraints );
+}
+
sub create_enum_type_constraint {
my ( $type_name, $values ) = @_;
my $type_atom = qr{ (?>$valid_chars+) }x;
my $ws = qr{ (?>\s*) }x;
my $op_union = qr{ $ws \| $ws }x;
+ my $op_intersection = qr{ $ws & $ws }x;
- my ($type, $type_capture_parts, $type_with_parameter, $union, $any);
+ my ($type, $type_capture_parts, $type_with_parameter, $union, $any, $intersection);
if (Class::MOP::IS_RUNNING_ON_5_10) {
my $type_pattern
= q{ (?&type_atom) (?: \[ (?&ws) (?&any) (?&ws) \] )? };
= q{ (?&type_atom) \[ (?&ws) (?&any) (?&ws) \] };
my $union_pattern
= q{ (?&type) (?> (?: (?&op_union) (?&type) )+ ) };
+ my $intersection_pattern
+ = q{ (?&type) (?> (?: (?&op_intersection) (?&type) )+ ) };
my $any_pattern
- = q{ (?&type) | (?&union) };
+ = q{ (?&type) | (?&union) | (?&intersection) };
my $defines = qr{(?(DEFINE)
(?<valid_chars> $valid_chars)
(?<type_atom> $type_atom)
(?<ws> $ws)
(?<op_union> $op_union)
+ (?<op_intersection> $op_intersection)
(?<type> $type_pattern)
(?<type_capture_parts> $type_capture_parts_pattern)
(?<type_with_parameter> $type_with_parameter_pattern)
(?<union> $union_pattern)
+ (?<intersection> $intersection_pattern)
(?<any> $any_pattern)
)}x;
$type_capture_parts = qr{ $type_capture_parts_pattern $defines }x;
$type_with_parameter = qr{ $type_with_parameter_pattern $defines }x;
$union = qr{ $union_pattern $defines }x;
+ $intersection = qr{ $intersection_pattern $defines }x;
$any = qr{ $any_pattern $defines }x;
}
else {
= qr{ $type_atom \[ $ws (??{$any}) $ws \] }x;
$union
= qr{ $type (?> (?: $op_union $type )+ ) }x;
+ $intersection
+ = qr{ $type (?> (?: $op_intersection $type )+ ) }x;
$any
- = qr{ $type | $union }x;
+ = qr{ $type | $union | $intersection }x;
}
@rv;
}
+ sub _parse_type_constraint_intersection {
+ { no warnings 'void'; $any; } # force capture of interpolated lexical
+ my $given = shift;
+ my @rv;
+ while ( $given =~ m{ \G (?: $op_intersection )? ($type) }gcx ) {
+ push @rv => $1;
+ }
+ (pos($given) eq length($given))
+ || __PACKAGE__->_throw_error("'$given' didn't parse (parse-pos="
+ . pos($given)
+ . " and str-length="
+ . length($given)
+ . ")");
+ @rv;
+ }
+
sub _detect_type_constraint_union {
{ no warnings 'void'; $any; } # force capture of interpolated lexical
$_[0] =~ m{^ $type $op_union $type ( $op_union .* )? $}x;
}
+
+ sub _detect_type_constraint_intersection {
+ { no warnings 'void'; $any; } # force capture of interpolated lexical
+ $_[0] =~ m{^ $type $op_intersection $type ( $op_intersection .* )? $}x;
+ }
}
## --------------------------------------------------------
qw(
Moose::Meta::TypeConstraint
Moose::Meta::TypeConstraint::Union
+ Moose::Meta::TypeConstraint::Intersection
Moose::Meta::TypeConstraint::Parameterized
Moose::Meta::TypeConstraint::Parameterizable
Moose::Meta::TypeConstraint::Class
enum 'RGBColors', [qw(red green blue)];
+ union 'StringOrArray', [qw( String Array )];
+
no Moose::Util::TypeConstraints;
=head1 DESCRIPTION
isa => enum([qw[ ascending descending ]]),
);
+=item B<union ($name, \@constraints)>
+
+This will create a basic subtype where any of the provided constraints
+may match in order to satisfy this constraint.
+
+=item B<union (\@constraints)>
+
+If passed an ARRAY reference as the only parameter instead of the
+C<$name>, C<\@constraints> pair, this will create an unnamed union.
+This can then be used in an attribute definition like so:
+
+ has 'items' => (
+ is => 'ro',
+ isa => union([qw[ Str ArrayRef ]]),
+ );
+
+This is similar to the existing string union:
+
+ isa => 'Str|ArrayRef'
+
+except that it supports anonymous elements as child constraints:
+
+ has 'color' => (
+ isa => 'ro',
+ isa => union([ 'Int', enum([qw[ red green blue ]]) ]),
+ );
+
=item B<as 'Parent'>
This is just sugar for the type constraint construction syntax.
The subroutine should return a code string suitable for inlining. You can
assume that the check will be wrapped in parentheses when it is inlined.
-The inlined code should include any checks that your type's parent type's
-do. For example, the C<Num> type's inlining sub looks like this:
+The inlined code should include any checks that your type's parent types
+do. For example, the C<Value> type's inlining sub looks like this:
sub {
- '!ref(' . $_[1] . ') '
- . '&& Scalar::Util::looks_like_number(' . $_[1] . ')'
+ 'defined(' . $_[1] . ')'
+ . ' && !ref(' . $_[1] . ')'
}
-Note that it checks if the variable is a reference, since it is a subtype of
-the C<Value> type.
+Note that it checks if the variable is defined, since it is a subtype of
+the C<Defined> type. However, to avoid repeating code, this can be optimized as:
+
+ sub {
+ $_[0]->parent()->_inline_check($_[1])
+ . ' && !ref(' . $_[1] . ')'
+ }
=item B<optimize_as { ... }>
=item B<create_type_constraint_union($pipe_separated_types | @type_constraint_names)>
+=item B<create_named_type_constraint_union($name, $pipe_separated_types | @type_constraint_names)>
+
This can take a union type specification like C<'Int|ArrayRef[Int]'>,
or a list of names. It returns a new
L<Moose::Meta::TypeConstraint::Union> object.
+=item B<create_type_constraint_intersection ($pipe_separated_types | @type_constraint_names)>
+
+Given string with C<$pipe_separated_types> or a list of C<@type_constraint_names>,
+this will return a L<Moose::Meta::TypeConstraint::Intersection> instance.
+
=item B<create_parameterized_type_constraint($type_name)>
Given a C<$type_name> in the form of C<'BaseType[ContainerType]'>,
projects / gitmo/Moose.git / blobdiff