From: Yuval Kogman Date: Sat, 18 Apr 2009 17:23:24 +0000 (+0200) Subject: fix is subtype of (sortof) X-Git-Tag: 0.12~4 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMooseX-Types-Structured.git;a=commitdiff_plain;h=179af711f82dd08536a45a6d915978e6bd59d433;hp=d716430a1f595e7bd54039e440a0286102fc87f1 fix is subtype of (sortof) --- diff --git a/lib/MooseX/Meta/TypeConstraint/Structured.pm b/lib/MooseX/Meta/TypeConstraint/Structured.pm index d7b655b..f199370 100644 --- a/lib/MooseX/Meta/TypeConstraint/Structured.pm +++ b/lib/MooseX/Meta/TypeConstraint/Structured.pm @@ -202,12 +202,67 @@ sub equals { return unless $other->isa(__PACKAGE__); return ( - $self->type_constraints_equals($other) + $self->parent->equals($other->parent) and - $self->parent->equals( $other->parent ) + $self->type_constraints_equals($other) ); } +sub is_a_type_of { + my ( $self, $type_or_name ) = @_; + my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); + + if ( $other->isa(__PACKAGE__) and @{ $other->type_constraints || [] }) { + warn "structured ( $self, $other )"; + if ( $self->parent->is_a_type_of($other->parent) ) { + warn "related ( $self, $other )"; + return $self->_type_constraints_op_all($other, "is_a_type_of"); + } elsif ( $self->parent->is_a_type_of($other) ) { + return 1; + # FIXME compare? + } else { + return 0; + } + } else { + return $self->SUPER::is_a_type_of($other); + } +} + +sub is_subtype_of { + my ( $self, $type_or_name ) = @_; + + my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name); + + if ( $other->isa(__PACKAGE__) ) { + if ( $other->type_constraints and $self->type_constraints ) { + if ( $self->parent->is_a_type_of($other->parent) ) { + return ( + $self->_type_constraints_op_all($other, "is_a_type_of") + and + $self->_type_constraints_op_any($other, "is_subtype_of") + ); + } elsif ( $self->parent->is_a_type_of($other) ) { + return 1; + # FIXME compare? + } else { + return 0; + } + } else { + if ( $self->type_constraints ) { + if ( $self->SUPER::is_subtype_of($other) ) { + return 1; + } else { + return; + } + } else { + return $self->parent->is_subtype_of($other->parent); + } + } + } else { + return $self->SUPER::is_subtype_of($other); + } +} + =head2 type_constraints_equals Checks to see if the internal type contraints are equal. @@ -215,29 +270,58 @@ Checks to see if the internal type contraints are equal. =cut sub type_constraints_equals { - my ($self, $other) = @_; + my ( $self, $other ) = @_; + $self->_type_constraints_op_all($other, "equals"); +} + +sub _type_constraints_op_all { + my ($self, $other, $op) = @_; + + return unless $other->isa(__PACKAGE__); + my @self_type_constraints = @{$self->type_constraints||[]}; my @other_type_constraints = @{$other->type_constraints||[]}; - + + return unless @self_type_constraints == @other_type_constraints; + ## Incoming ay be either arrayref or hashref, need top compare both while(@self_type_constraints) { my $self_type_constraint = shift @self_type_constraints; - my $other_type_constraint = shift @other_type_constraints - || return; ## $other needs the same number of children. + my $other_type_constraint = shift @other_type_constraints; - if( ref $self_type_constraint) { - $self_type_constraint->equals($other_type_constraint) - || return; ## type constraints obviously need top be equal - } else { - $self_type_constraint eq $other_type_constraint - || return; ## strings should be equal - } + $_ = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($_) + for $self_type_constraint, $other_type_constraint; + $self_type_constraint->$op($other_type_constraint) or return; } return 1; ##If we get this far, everything is good. } +sub _type_constraints_op_any { + my ($self, $other, $op) = @_; + + return unless $other->isa(__PACKAGE__); + + my @self_type_constraints = @{$self->type_constraints||[]}; + my @other_type_constraints = @{$other->type_constraints||[]}; + + return unless @self_type_constraints == @other_type_constraints; + + ## Incoming ay be either arrayref or hashref, need top compare both + while(@self_type_constraints) { + my $self_type_constraint = shift @self_type_constraints; + my $other_type_constraint = shift @other_type_constraints; + + $_ = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($_) + for $self_type_constraint, $other_type_constraint; + + return 1 if $self_type_constraint->$op($other_type_constraint); + } + + return 0; +} + =head2 get_message Give you a better peek into what's causing the error. For now we stringify the @@ -271,4 +355,4 @@ it under the same terms as Perl itself. =cut -__PACKAGE__->meta->make_immutable; \ No newline at end of file +__PACKAGE__->meta->make_immutable; diff --git a/t/06-api.t b/t/06-api.t index 2c9dc3e..cbfb687 100644 --- a/t/06-api.t +++ b/t/06-api.t @@ -1,14 +1,14 @@ BEGIN { use strict; use warnings; - use Test::More tests=>68; + use Test::More tests=>83; } use Moose::Util::TypeConstraints; use MooseX::Types::Structured qw(Dict Tuple); -use MooseX::Types::Moose qw(Int Str Object ArrayRef HashRef); +use MooseX::Types::Moose qw(Int Str Item Object ArrayRef HashRef); use MooseX::Types -declare => [qw( - MyDict1 MyDict2 MyDict3 subMyDict3 subMyDict1 + MyDict1 MyDict2 MyDict3 MyDict4 subMyDict3 subMyDict1 MyTuple1 MyTuple2 MyTuple3 subMyTuple3 )]; @@ -29,6 +29,9 @@ subtype MyDict3, subtype subMyDict3, as MyDict3; +subtype MyDict4, + as Dict[name=>Str, age=>Item]; + ## Create some sample Tuples subtype MyTuple1, @@ -62,9 +65,15 @@ ok (!MyTuple3->equals(MyTuple1), 'MyTuple3 == MyTuple1'); ok ( MyDict1->equals(MyDict2), 'MyDict1 == MyDict2'); ok ( MyDict2->equals(MyDict1), 'MyDict2 == MyDict1'); ok (!MyDict1->equals(MyDict3), 'MyDict1 == MyDict3'); +ok (!MyDict1->equals(MyDict4), 'MyDict1 == MyDict3'); ok (!MyDict2->equals(MyDict3), 'MyDict2 == MyDict3'); +ok (!MyDict2->equals(MyDict4), 'MyDict2 == MyDict3'); ok (!MyDict3->equals(MyDict2), 'MyDict3 == MyDict2'); +ok (!MyDict3->equals(MyDict4), 'MyDict3 == MyDict2'); ok (!MyDict3->equals(MyDict1), 'MyDict3 == MyDict1'); +ok (!MyDict4->equals(MyDict1), 'MyDict3 == MyDict1'); +ok (!MyDict4->equals(MyDict2), 'MyDict3 == MyDict1'); +ok (!MyDict4->equals(MyDict3), 'MyDict3 == MyDict1'); ok ( MyTuple1->equals(MyTuple2), 'MyTuple1 == MyTuple2'); ok ( MyTuple2->equals(MyTuple1), 'MyTuple2 == MyTuple1'); @@ -75,6 +84,7 @@ ok (!MyTuple3->equals(MyTuple1), 'MyTuple3 == MyTuple1'); ## Test is_a_type_of +ok ( MyDict1->is_a_type_of(HashRef), 'MyDict1 is_a_type_of HashRef'); ok ( MyDict1->is_a_type_of(Dict), 'MyDict1 is_a_type_of Dict'); ok (!MyDict1->is_a_type_of(Tuple), 'MyDict1 NOT is_a_type_of Tuple'); ok ( MyDict1->is_a_type_of(MyDict2), 'MyDict1 is_a_type_of MyDict2'); @@ -85,6 +95,13 @@ ok ( subMyDict1->is_a_type_of(Dict), 'subMyDict1 type of Dict'); ok ( subMyDict1->is_a_type_of(MyDict1), 'subMyDict1 type of MyDict1'); ok ( subMyDict1->is_a_type_of(subMyDict1), 'subMyDict1 type of subMyDict1'); ok ( subMyDict1->is_a_type_of(MyDict2), 'subMyDict1 type of MyDict2'); +ok ( MyDict4->is_a_type_of(HashRef), 'MyDict4 is_a_type_of HashRef'); +ok ( MyDict4->is_a_type_of(Dict), 'MyDict4 is_a_type_of Dict'); +ok (!MyDict4->is_a_type_of(Tuple), 'MyDict4 NOT is_a_type_of Tuple'); +ok (!MyDict4->is_a_type_of(MyDict2), 'MyDict4 NOT is_a_type_of MyDict2'); +ok ( MyDict2->is_a_type_of(MyDict4), 'MyDict2 is_a_type_of MyDict4'); +ok (!MyDict4->is_a_type_of(MyDict3), 'MyDict4 NOT is_a_type_of MyDict3'); + ok ( MyTuple1->is_a_type_of(Tuple), 'MyTuple1 is_a_type_of Tuple'); ok (!MyTuple1->is_a_type_of(Dict), 'MyTuple1 NOT is_a_type_of Dict'); @@ -95,15 +112,17 @@ ok (!MyTuple2->is_a_type_of(MyTuple3), 'MyTuple2 NOT is_a_type_of MyTuple3'); ## is_subtype_of +ok ( MyDict1->is_subtype_of(HashRef), 'MyDict1 is_subtype_of HashRef'); ok ( MyDict1->is_subtype_of(Dict), 'MyDict1 is_subtype_of Dict'); +ok ( MyDict1->is_subtype_of(MyDict4), 'MyDict1 is_subtype_of MyDict4'); ok (!MyDict1->is_subtype_of(Tuple), 'MyDict1 NOT is_subtype_of Tuple'); -ok (!MyDict1->is_subtype_of(MyDict2), 'MyDict1 is_subtype_of MyDict2'); -ok (!MyDict2->is_subtype_of(MyDict1), 'MyDict2 is_subtype_of MyDict1'); +ok (!MyDict1->is_subtype_of(MyDict2), 'MyDict1 NOT is_subtype_of MyDict2'); +ok (!MyDict2->is_subtype_of(MyDict1), 'MyDict2 NOT is_subtype_of MyDict1'); ok (!MyDict1->is_subtype_of(MyDict3), 'MyDict1 NOT is_subtype_of MyDict3'); ok (!MyDict2->is_subtype_of(MyDict3), 'MyDict2 NOT is_subtype_of MyDict3'); ok ( subMyDict1->is_subtype_of(Dict), 'subMyDict1 is_subtype_of Dict'); ok ( subMyDict1->is_subtype_of(MyDict1), 'subMyDict1 is_subtype_of MyDict1'); -ok (!subMyDict1->is_subtype_of(subMyDict1), 'subMyDict1 is_subtype_of subMyDict1'); +ok (!subMyDict1->is_subtype_of(subMyDict1), 'subMyDict1 NOT is_subtype_of subMyDict1'); ok ( subMyDict1->is_subtype_of(MyDict2), 'subMyDict1 is_subtype_of MyDict2'); ok ( MyTuple1->is_subtype_of(Tuple), 'MyTuple1 is_subtype_of Tuple');