From: john napiorkowski Date: Sat, 23 May 2009 21:38:59 +0000 (-0400) Subject: fixed up the coercion stuff, got something that should give us 80%+ what we need X-Git-Tag: 0.01~10 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMooseX-Dependent.git;a=commitdiff_plain;h=26cf337eb5c6275eddbcda39f7187416d6314b2f fixed up the coercion stuff, got something that should give us 80%+ what we need --- diff --git a/lib/MooseX/Dependent/Meta/TypeCoercion/Dependent.pm b/lib/MooseX/Dependent/Meta/TypeCoercion/Dependent.pm index a2b718d..5640267 100644 --- a/lib/MooseX/Dependent/Meta/TypeCoercion/Dependent.pm +++ b/lib/MooseX/Dependent/Meta/TypeCoercion/Dependent.pm @@ -16,6 +16,59 @@ TBD This class defines the following methods. +=head + +=cut + +sub coerce { + my $self = shift @_; + my $coderef = $self->_compiled_type_coercion; + return $coderef->(@_); +} + +around 'add_type_coercions' => sub { + my ($add_type_coercions, $self, @args) = @_; + if($self->type_constraint->has_constraining_value) { + Moose->throw_error("Cannot add type coercions to a dependent type constraint that's been defined."); + } else { + return $self->$add_type_coercions(@args); + } +}; + +sub compile_type_coercion { + my $self = shift; + my @coercion_map = @{$self->type_coercion_map}; + my @coercions; + while (@coercion_map) { + my ($constraint_name, $action) = splice(@coercion_map, 0, 2); + my $type_constraint = ref $constraint_name ? $constraint_name : Moose::Util::TypeConstraints::find_or_parse_type_constraint($constraint_name); + + unless ( defined $type_constraint ) { + require Moose; + Moose->throw_error("Could not find the type constraint ($constraint_name) to coerce from"); + } + + push @coercions => [ + $type_constraint->_compiled_type_constraint, + $action + ]; + } + $self->_compiled_type_coercion(sub { + my $thing = shift; + foreach my $coercion (@coercions) { + my ($constraint, $converter) = @$coercion; + if ($constraint->($thing)) { + local $_ = $thing; + return $converter->($thing, @_); + } + } + return $thing; + }); +} + + + + =head1 SEE ALSO The following modules or resources may be of interest. diff --git a/lib/MooseX/Dependent/Meta/TypeConstraint/Dependent.pm b/lib/MooseX/Dependent/Meta/TypeConstraint/Dependent.pm index 6b6a962..1f1eb01 100644 --- a/lib/MooseX/Dependent/Meta/TypeConstraint/Dependent.pm +++ b/lib/MooseX/Dependent/Meta/TypeConstraint/Dependent.pm @@ -77,13 +77,13 @@ Do some post build stuff =cut -sub BUILD { - my ($self) = @_; - $self->coercion( - MooseX::Dependent::Meta::TypeCoercion::Dependent->new( - type_constraint => $self, - )); -} +around 'new' => sub { + my ($new, $class, @args) = @_; + my $self = $class->$new(@args); + my $coercion = MooseX::Dependent::Meta::TypeCoercion::Dependent->new(type_constraint => $self); + $self->coercion($coercion); + return $self; +}; =head2 parameterize (@args) @@ -190,7 +190,7 @@ sub parameterize { ); ## TODO This is probably going to have to go away (too many things added to the registry) - Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint); + ##Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint($type_constraint); return $type_constraint; } } @@ -310,14 +310,34 @@ around '_compiled_type_constraint' => sub { }; }; +## if the constraining value has been added, no way to do a coercion. around 'coerce' => sub { my ($coerce, $self, @args) = @_; - if($self->coercion) { - if(my $value = $self->$coerce(@args)) { - return $value if defined $value; + + if($self->has_constraining_value) { + push @args, $self->constraining_value; + if(@{$self->coercion->type_coercion_map}) { + my $coercion = $self->coercion; + warn "coercion map found in $coercion found for $self"; + my $coerced = $self->$coerce(@args); + if(defined $coerced) { + warn "got coerced args of ", $coerced; + return $coerced; + } else { + my $parent = $self->parent; + warn "no coercion for $self, using $parent"; + return $parent->coerce(@args); + } + } else { + my $parent = $self->parent; + #warn "no coercion for $self, using $parent"; + return $parent->coerce(@args); } } - return $self->parent->coerce(@args); + else { + return $self->$coerce(@args); + } + return; }; =head2 get_message @@ -346,5 +366,6 @@ it under the same terms as Perl itself. =cut -__PACKAGE__->meta->make_immutable(inline_constructor => 0); +1; +##__PACKAGE__->meta->make_immutable(inline_constructor => 0); diff --git a/lib/MooseX/Dependent/Types.pm b/lib/MooseX/Dependent/Types.pm index 57000a2..c08f822 100644 --- a/lib/MooseX/Dependent/Types.pm +++ b/lib/MooseX/Dependent/Types.pm @@ -152,55 +152,71 @@ is a capacity we current don't have. =head2 Coercions -You can place coercions on dependent types, however you need to pay attention to -what you are actually coercion, the unparameterized or parameterized constraint. - - TBD: Need discussion and example of coercions working for both the - constrainted and dependent type constraint. +Dependent types have some limited support for coercions. Several things must +be kept in mind. The first is that the coercion targets the type constraint +which is being made dependent, Not the dependent type. So for example if you +create a Dependent type like: + + subtype RequiredAgeInYears, + as Int; + + subtype PersonOverAge, + as Dependent[Person, RequiredAgeInYears] + where { + my ($person, $required_years_old) = @_; + return $person->years_old > $required_years_old; + } + +This would validate the following: + + my $person = Person->new(age=>35); + PersonOverAge([18])->check($person); - subtype OlderThanAge, - as Dependent[Int, Dict[older_than=>Int]], +You can then apply the following coercion + + coerce PersonOverAge, + from Dict[age=>int], + via {Person->new(%$_)}, + from Int, + via {Person->new(age=>$_)}; + +This coercion would then apply to all the following: + + PersonOverAge([18])->check(30); ## via the Int coercion + PersonOverAge([18])->check({age=>50}); ## via the Dict coercion + +However, you are not allowed to place coercions on dependent types that have +had their constraining value filled, nor subtypes of such. For example: + + coerce PersonOverAge[18], + from DateTime, + via {$_->years}; + +That would generate a hard exception. This is a limitation for now until I can +devise a smarter way to cache the generated type constraints. However, I doubt +it will be a significant limitation, since the general use case is supported. + +Lastly, the constraining value is available in the coercion in much the same way +it is available to the constraint. + + ## Create a type constraint where a Person must be in the set + subtype PersonInSet, + as Dependent[Person, PersonSet], where { - my ($value, $dict) = @_; - return $value > $dict->{older_than} ? 1:0; - }; - -Which should work like: - - OlderThanAge([{older_than=>25}])->check(39); ## is OK - OlderThanAge([older_than=>1])->check(9); ## OK, using reference type inference - -And you can create coercions like: + my ($person, $person_set) = @_; + $person_set->find($person); + } - coerce OlderThanAge, - from Tuple[Int, Int], + coerce PersonInSet, + from HashRef, via { - my ($int, $int); - return [$int, {older_than=>$int}]; + my ($hashref, $person_set) = @_; + return $person_set->create($hash_ref); }; =head2 Recursion -Newer versions of L support recursive type constraints. That is -you can include a type constraint as a contained type constraint of itself. -Recursion is support in both the dependent and constraining type constraint. For -example, if we assume an Object hierarchy like Food -> [Grass, Meat] - - TODO: DOES THIS EXAMPLE MAKE SENSE? - - subtype Food, - as Dependent[Food, Food], - where { - my ($value, $allowed_food_type) = @_; - return $value->isa($allowed_food_type); - }; - - my $grass = Food::Grass->new; - my $meat = Food::Meat->new; - my $vegetarian = Food[$grass]; - - $vegetarian->check($grass); ## Grass is the allowed food of a vegetarian - $vegetarian->check($meat); ## BANG, vegetarian can't eat meat! + TBD =head1 TYPE CONSTRAINTS diff --git a/t/03-coercions.t b/t/03-coercions.t index db900d3..5fc8262 100644 --- a/t/03-coercions.t +++ b/t/03-coercions.t @@ -1,5 +1,5 @@ -use Test::More tests=>14; { +use Test::More tests=>15; { use strict; use warnings; @@ -8,7 +8,7 @@ use Test::More tests=>14; { use MooseX::Types::Moose qw(Int Str HashRef ArrayRef); use MooseX::Types -declare=>[qw( - InfoHash OlderThanAge + InfoHash OlderThanAge DefinedOlderThanAge )]; ok subtype( InfoHash, @@ -32,31 +32,17 @@ use Test::More tests=>14; { ok OlderThanAge([older_than=>1])->check(9), '9 is older than 1'; ok !OlderThanAge([older_than=>1])->check('aaa'), '"aaa" not an int'; ok !OlderThanAge([older_than=>10])->check(9), '9 is not older than 10'; - - my $a = OlderThanAge([older_than=>1]); - - coerce $a, - from ArrayRef, - via { - my ($arrayref, $constraining_value) = @_; - my $age; - $age += $_ for @$arrayref; - return $age; - }; - - is $a->coerce([1,2,3]), 6, 'Got expected Value'; - + coerce OlderThanAge, from HashRef, - via { + via { my ($hashref, $constraining_value) = @_; - return keys %$hashref; - }; - - coerce OlderThanAge([older_than=>5]), + return scalar(keys(%$hashref)); + }, from ArrayRef, - via { + via { my ($arrayref, $constraining_value) = @_; + #use Data::Dump qw/dump/; warn dump $constraining_value; my $age; $age += $_ for @$arrayref; return $age; @@ -66,10 +52,27 @@ use Test::More tests=>14; { 'Got corect name for OlderThanAge'; is OlderThanAge([older_than=>5])->coerce([1..10]), 55, 'Coerce works'; + is OlderThanAge([older_than=>5])->coerce({a=>1,b=>2,c=>3,d=>4}), 4, + 'inherit Coerce works'; like OlderThanAge([older_than=>2])->name, qr/main::OlderThanAge\[/, 'Got correct name for OlderThanAge([older_than=>2])'; - is OlderThanAge([older_than=>2])->coerce({a=>1,b=>2,c=>3,d=>4}), 4, + is OlderThanAge([older_than=>2])->coerce({a=>5,b=>6,c=>7,d=>8}), 4, 'inherited Coerce works'; - - + + SKIP: { + skip 'Type Coercions on defined types not supported yet', 1; + + subtype DefinedOlderThanAge, as OlderThanAge([older_than=>1]); + + coerce DefinedOlderThanAge, + from ArrayRef, + via { + my ($arrayref, $constraining_value) = @_; + my $age; + $age += $_ for @$arrayref; + return $age; + }; + + is DefinedOlderThanAge->coerce([1,2,3]), 6, 'Got expected Value'; + } } \ No newline at end of file