--- /dev/null
+package Moose::Meta::TypeConstraint::Parameterizable;
+
+use strict;
+use warnings;
+use metaclass;
+
+our $VERSION = '0.01';
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::TypeConstraint';
+
+__PACKAGE__->meta->add_attribute('constraint_generator' => (
+ accessor => 'constraint_generator',
+ predicate => 'has_constraint_generator',
+));
+
+sub generate_constraint_for {
+ my ($self, $type) = @_;
+
+ return unless $self->has_constraint_generator;
+
+ return $self->constraint_generator->($type->type_parameter)
+ if $type->is_subtype_of($self->name);
+
+ return $self->_can_coerce_constraint_from($type)
+ if $self->has_coercion
+ && $self->coercion->has_coercion_for_type($type->parent->name);
+
+ return;
+}
+
+sub _can_coerce_constraint_from {
+ my ($self, $type) = @_;
+ my $coercion = $self->coercion;
+ my $constraint = $self->constraint_generator->($type->type_parameter);
+ return sub {
+ local $_ = $coercion->coerce($_);
+ $constraint->(@_);
+ };
+}
+
+
+1;
+
+__END__
+
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::TypeConstraint::Parameterizable - Higher Order type constraints for Moose
+
+=head1 METHODS
+
+=over 4
+
+=item B<constraint_generator>
+
+=item B<has_constraint_generator>
+
+=item B<generate_constraint_for>
+
+=item B<meta>
+
+=back
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no
+exception. If you find a bug please either email me, or add the bug
+to cpan-RT.
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
(blessed $type_parameter && $type_parameter->isa('Moose::Meta::TypeConstraint'))
|| confess "The type parameter must be a Moose meta type";
-
- my $constraint;
- my $name = $self->parent->name;
-
- my $array_coercion =
- Moose::Util::TypeConstraints::find_type_constraint('ArrayRef')
- ->coercion;
-
- my $hash_coercion =
- Moose::Util::TypeConstraints::find_type_constraint('HashRef')
- ->coercion;
-
- # ArrayRef[Foo] will check each element for the Foo constraint
- my $array_constraint = sub {
- foreach my $x (@$_) {
- ($type_parameter->check($x)) || return
- } 1;
- };
-
- # HashRef[Foo] will check each value for the Foo constraint
- my $hash_constraint = sub {
- foreach my $x (values %$_) {
- ($type_parameter->check($x)) || return
- } 1;
- };
-
- # if this is a subtype of ArrayRef, then we can use the ArrayRef[Foo]
- # constraint directly
- if ($self->is_subtype_of('ArrayRef')) {
- $constraint = $array_constraint;
- }
- # if this is a subtype of HashRef, then we can use the HashRef[Foo]
- # constraint directly
- elsif ($self->is_subtype_of('HashRef')) {
- $constraint = $hash_constraint;
- }
- # if we can coerce this type to an ArrayRef, do it and use the regular
- # ArrayRef[Foo] constraint
- elsif ($array_coercion && $array_coercion->has_coercion_for_type($name)) {
- $constraint = sub {
- local $_ = $array_coercion->coerce($_);
- $array_constraint->(@_);
- };
- }
- # if we can coerce this type to a HashRef, do it and use the regular
- # HashRef[Foo] constraint
- elsif ($hash_coercion && $hash_coercion->has_coercion_for_type($name)) {
- $constraint = sub {
- local $_ = $hash_coercion->coerce($_);
- $hash_constraint->(@_);
- };
- }
- else {
- confess "The " . $self->name . " constraint cannot be used, because " . $name . " doesn't subtype or coerce ArrayRef or HashRef.";
+
+ foreach my $type (Moose::Util::TypeConstraints::get_all_parameterizable_types()) {
+ if (my $constraint = $type->generate_constraint_for($self)) {
+ $self->_set_constraint($constraint);
+ return $self->SUPER::compile_type_constraint;
+ }
}
- $self->_set_constraint($constraint);
-
- $self->SUPER::compile_type_constraint;
+ # if we get here, then we couldn't
+ # find a way to parameterize this type
+ confess "The " . $self->name . " constraint cannot be used, because "
+ . $self->parent->name . " doesn't subtype or coerce from a parameterizable type.";
}
1;
use Moose::Meta::TypeConstraint;
use Moose::Meta::TypeConstraint::Union;
use Moose::Meta::TypeConstraint::Parameterized;
+use Moose::Meta::TypeConstraint::Parameterizable;
use Moose::Meta::TypeCoercion;
use Moose::Meta::TypeCoercion::Union;
use Moose::Meta::TypeConstraint::Registry;
=> optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Int;
subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::ScalarRef;
-subtype 'ArrayRef' => as 'Ref' => where { ref($_) eq 'ARRAY' } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::ArrayRef;
-subtype 'HashRef' => as 'Ref' => where { ref($_) eq 'HASH' } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::HashRef;
subtype 'CodeRef' => as 'Ref' => where { ref($_) eq 'CODE' } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::CodeRef;
subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef;
subtype 'GlobRef' => as 'Ref' => where { ref($_) eq 'GLOB' } => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::GlobRef;
=> { optimize => $_class_name_checker };
## --------------------------------------------------------
+# parameterizable types ...
+
+$REGISTRY->add_type_constraint(
+ Moose::Meta::TypeConstraint::Parameterizable->new(
+ name => 'ArrayRef',
+ package_defined_in => __PACKAGE__,
+ parent => find_type_constraint('Ref'),
+ constraint => sub { ref($_) eq 'ARRAY' },
+ optimized => \&Moose::Util::TypeConstraints::OptimizedConstraints::ArrayRef,
+ constraint_generator => sub {
+ my $type_parameter = shift;
+ return sub {
+ foreach my $x (@$_) {
+ ($type_parameter->check($x)) || return
+ } 1;
+ }
+ }
+ )
+);
+
+$REGISTRY->add_type_constraint(
+ Moose::Meta::TypeConstraint::Parameterizable->new(
+ name => 'HashRef',
+ package_defined_in => __PACKAGE__,
+ parent => find_type_constraint('Ref'),
+ constraint => sub { ref($_) eq 'HASH' },
+ optimized => \&Moose::Util::TypeConstraints::OptimizedConstraints::HashRef,
+ constraint_generator => sub {
+ my $type_parameter = shift;
+ return sub {
+ foreach my $x (values %$_) {
+ ($type_parameter->check($x)) || return
+ } 1;
+ }
+ }
+ )
+);
+
+$REGISTRY->add_type_constraint(
+ Moose::Meta::TypeConstraint::Parameterizable->new(
+ name => 'Maybe',
+ package_defined_in => __PACKAGE__,
+ parent => find_type_constraint('Item'),
+ constraint => sub { 1 },
+ constraint_generator => sub {
+ my $type_parameter = shift;
+ return sub {
+ return 1 if not(defined($_)) || $type_parameter->check($_);
+ return;
+ }
+ }
+ )
+);
+
+my @PARAMETERIZABLE_TYPES = map {
+ $REGISTRY->get_type_constraint($_)
+} qw[ArrayRef HashRef Maybe];
+
+sub get_all_parameterizable_types { @PARAMETERIZABLE_TYPES }
+sub add_parameterizable_type {
+ my $type = shift;
+ (blessed $type && $type->isa('Moose::Meta::TypeConstraint::Parameterizable'))
+ || confess "Type must be a Moose::Meta::TypeConstraint::Parameterizable not $type";
+ push @PARAMETERIZABLE_TYPES => $type;
+}
+
+## --------------------------------------------------------
# end of built-in types ...
## --------------------------------------------------------
Any
Item
Bool
+ Maybe[`a]
Undef
Defined
Value
ClassName
Ref
ScalarRef
- ArrayRef
- HashRef
+ ArrayRef[`a]
+ HashRef[`a]
CodeRef
RegexpRef
GlobRef
Suggestions for improvement are welcome.
-B<NOTE:> The C<Undef> type constraint does not work correctly
-in every occasion, please use it sparringly.
+B<NOTE:> Any type followed by a type parameter C<[`a]> can be
+parameterized, this means you can say:
+
+ ArrayRef[Int] # an array of intergers
+ HashRef[CodeRef] # a hash of str to CODE ref mappings
+ Maybe[Str] # value may be a string, may be undefined
+
+B<NOTE:> The C<Undef> type constraint for the most part works
+correctly now, but edge cases may still exist, please use it
+sparringly.
-B<NOTE:> The C<ClassName> type constraint is simply a subtype
-of string which responds true to C<isa('UNIVERSAL')>. This means
-that your class B<must> be loaded for this type constraint to
-pass. I know this is not ideal for all, but it is a saner
-restriction than most others.
+B<NOTE:> The C<ClassName> type constraint does a complex package
+existence check. This means that your class B<must> be loaded for
+this type constraint to pass. I know this is not ideal for all,
+but it is a saner restriction than most others.
=head2 Use with Other Constraint Modules
BaseType[ContainerType]
this will extract the base type and container type and build an instance of
-L<Moose::Meta::TypeConstraint::Parameterized> for it.
+L<Moose::Meta::TypeConstraint::Parameterized> for it.
=item B<create_class_type_constraint ($class)>
into the caller's namespace. Right now, this is mostly used for
testing, but it might prove useful to others.
+=item B<get_all_parameterizable_types>
+
+This returns all the parameterizable types that have been registered.
+
+=item B<add_parameterizable_type ($type)>
+
+Adds C<$type> to the list of parameterizable types
+
=back
=head2 Type Constraint Constructors
ok(!$t->check({ one1 => 1, two2 => 2 }), '... validated it correctly');
}
-my $hoi = Moose::Meta::TypeConstraint::Parameterized->new(
- name => 'AlphaKeyHash[Int]',
- parent => find_type_constraint('AlphaKeyHash'),
- type_parameter => find_type_constraint('Int'),
-);
+my $hoi = Moose::Util::TypeConstraints::find_or_create_type_constraint('AlphaKeyHash[Int]');
ok($hoi->check({ one => 1, two => 2 }), '... validated it correctly');
ok(!$hoi->check({ one1 => 1, two2 => 2 }), '... validated it correctly');
ok(!$hoi->check({ one => 'uno', two => 'dos' }), '... validated it correctly');
ok(!$hoi->check({ one1 => 'un', two2 => 'deux' }), '... validated it correctly');
-my $th = Moose::Meta::TypeConstraint::Parameterized->new(
- name => 'Trihash[Bool]',
- parent => find_type_constraint('Trihash'),
- type_parameter => find_type_constraint('Bool'),
-);
+my $th = Moose::Util::TypeConstraints::find_or_create_type_constraint('Trihash[Bool]');
ok(!$th->check({ one => 1, two => 1 }), '... validated it correctly');
ok($th->check({ one => 1, two => 0, three => 1 }), '... validated it correctly');
=> via { [ $_->items ] }
} '... created the coercion okay';
-my $mylist = Moose::Meta::TypeConstraint::Parameterized->new(
- name => 'MyList[Int]',
- parent => find_type_constraint('MyList'),
- type_parameter => find_type_constraint('Int'),
-);
+my $mylist = Moose::Util::TypeConstraints::find_or_create_type_constraint('MyList[Int]');
-ok($mylist->check(MyList->new(10, 20, 30)), '... validated it correctly');
-ok(!$mylist->check(MyList->new(10, "two")), '... validated it correctly');
-ok(!$mylist->check([10]), '... validated it correctly');
+ok($mylist->check(MyList->new(10, 20, 30)), '... validated it correctly (pass)');
+ok(!$mylist->check(MyList->new(10, "two")), '... validated it correctly (fail)');
+ok(!$mylist->check([10]), '... validated it correctly (fail)');
subtype 'EvenList' => as 'MyList' => where { $_->items % 2 == 0 };
=> via { [ $_->items ] }
} '... created the coercion okay';
-my $evenlist = Moose::Meta::TypeConstraint::Parameterized->new(
- name => 'EvenList[Int]',
- parent => find_type_constraint('EvenList'),
- type_parameter => find_type_constraint('Int'),
-);
+my $evenlist = Moose::Util::TypeConstraints::find_or_create_type_constraint('EvenList[Int]');
-ok(!$evenlist->check(MyList->new(10, 20, 30)), '... validated it correctly');
-ok($evenlist->check(MyList->new(10, 20, 30, 40)), '... validated it correctly');
-ok(!$evenlist->check(MyList->new(10, "two")), '... validated it correctly');
-ok(!$evenlist->check([10, 20]), '... validated it correctly');
+ok(!$evenlist->check(MyList->new(10, 20, 30)), '... validated it correctly (fail)');
+ok($evenlist->check(MyList->new(10, 20, 30, 40)), '... validated it correctly (pass)');
+ok(!$evenlist->check(MyList->new(10, "two")), '... validated it correctly (fail)');
+ok(!$evenlist->check([10, 20]), '... validated it correctly (fail)');
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 12;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Moose');
+ use_ok('Moose::Util::TypeConstraints');
+}
+
+my $type = Moose::Util::TypeConstraints::find_or_create_type_constraint('Maybe[Int]');
+isa_ok($type, 'Moose::Meta::TypeConstraint');
+isa_ok($type, 'Moose::Meta::TypeConstraint::Parameterized');
+
+ok($type->check(10), '... checked type correctly (pass)');
+ok($type->check(undef), '... checked type correctly (pass)');
+ok(!$type->check('Hello World'), '... checked type correctly (fail)');
+ok(!$type->check([]), '... checked type correctly (fail)');
+
+{
+ package Foo;
+ use Moose;
+
+ has 'bar' => (is => 'rw', isa => 'Maybe[ArrayRef]', required => 1);
+}
+
+lives_ok {
+ Foo->new(bar => []);
+} '... it worked!';
+
+lives_ok {
+ Foo->new(bar => undef);
+} '... it worked!';
+
+dies_ok {
+ Foo->new(bar => 100);
+} '... failed the type check';
+
+dies_ok {
+ Foo->new(bar => 'hello world');
+} '... failed the type check';
+
projects / gitmo/Moose.git / commitdiff