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.
=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)
);
## 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;
}
}
};
};
+## 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
=cut
-__PACKAGE__->meta->make_immutable(inline_constructor => 0);
+1;
+##__PACKAGE__->meta->make_immutable(inline_constructor => 0);
=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<MooseX::Types> 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
-use Test::More tests=>14; {
+use Test::More tests=>15; {
use strict;
use warnings;
use MooseX::Types::Moose qw(Int Str HashRef ArrayRef);
use MooseX::Types -declare=>[qw(
- InfoHash OlderThanAge
+ InfoHash OlderThanAge DefinedOlderThanAge
)];
ok subtype( InfoHash,
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;
'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
projects / gitmo/MooseX-Dependent.git / commitdiff