From: Stevan Little Date: Thu, 17 Jan 2008 06:24:03 +0000 (+0000) Subject: refactoring the parameterized type constraints X-Git-Tag: 0_35~14 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7e4e1ad46fd4c72845b18df57a80cdc03b47c4c4;p=gitmo%2FMoose.git refactoring the parameterized type constraints --- diff --git a/lib/Moose/Meta/TypeConstraint/Parameterizable.pm b/lib/Moose/Meta/TypeConstraint/Parameterizable.pm new file mode 100644 index 0000000..162e394 --- /dev/null +++ b/lib/Moose/Meta/TypeConstraint/Parameterizable.pm @@ -0,0 +1,87 @@ +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 + +=item B + +=item B + +=item B + +=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 Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/Moose/Meta/TypeConstraint/Parameterized.pm b/lib/Moose/Meta/TypeConstraint/Parameterized.pm index 7020507..7bbc54a 100644 --- a/lib/Moose/Meta/TypeConstraint/Parameterized.pm +++ b/lib/Moose/Meta/TypeConstraint/Parameterized.pm @@ -28,65 +28,18 @@ sub compile_type_constraint { (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; diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 9ebc42f..3f4d12d 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -48,6 +48,7 @@ sub _install_type_coercions ($$); 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; @@ -433,8 +434,6 @@ subtype 'Int' => 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; @@ -494,6 +493,73 @@ subtype 'ClassName' => { 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 ... ## -------------------------------------------------------- @@ -579,6 +645,7 @@ could probably use some work, but it works for me at the moment. Any Item Bool + Maybe[`a] Undef Defined Value @@ -588,8 +655,8 @@ could probably use some work, but it works for me at the moment. ClassName Ref ScalarRef - ArrayRef - HashRef + ArrayRef[`a] + HashRef[`a] CodeRef RegexpRef GlobRef @@ -599,14 +666,21 @@ could probably use some work, but it works for me at the moment. Suggestions for improvement are welcome. -B The C type constraint does not work correctly -in every occasion, please use it sparringly. +B 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 The C type constraint for the most part works +correctly now, but edge cases may still exist, please use it +sparringly. -B The C type constraint is simply a subtype -of string which responds true to C. This means -that your class B 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 The C type constraint does a complex package +existence check. This means that your class B 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 @@ -660,7 +734,7 @@ Given a C<$type_name> in the form of: BaseType[ContainerType] this will extract the base type and container type and build an instance of -L for it. +L for it. =item B @@ -710,6 +784,14 @@ This will export all the current type constraints as functions into the caller's namespace. Right now, this is mostly used for testing, but it might prove useful to others. +=item B + +This returns all the parameterizable types that have been registered. + +=item B + +Adds C<$type> to the list of parameterizable types + =back =head2 Type Constraint Constructors diff --git a/t/040_type_constraints/018_custom_parameterized_types.t b/t/040_type_constraints/018_custom_parameterized_types.t index 0649653..da19c8f 100644 --- a/t/040_type_constraints/018_custom_parameterized_types.t +++ b/t/040_type_constraints/018_custom_parameterized_types.t @@ -45,22 +45,14 @@ lives_ok { 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'); diff --git a/t/040_type_constraints/019_coerced_parameterized_types.t b/t/040_type_constraints/019_coerced_parameterized_types.t index 8c0d57c..9010448 100644 --- a/t/040_type_constraints/019_coerced_parameterized_types.t +++ b/t/040_type_constraints/019_coerced_parameterized_types.t @@ -32,15 +32,11 @@ lives_ok { => 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 }; @@ -53,14 +49,10 @@ lives_ok { => 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)'); diff --git a/t/040_type_constraints/021_maybe_type_constraint.t b/t/040_type_constraints/021_maybe_type_constraint.t new file mode 100644 index 0000000..e59f501 --- /dev/null +++ b/t/040_type_constraints/021_maybe_type_constraint.t @@ -0,0 +1,45 @@ +#!/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'; +