From: Yuval Kogman <nothingmuch@woobling.org>
Date: Sat, 12 Apr 2008 20:38:42 +0000 (+0000)
Subject: fix and test equals for various TC classes, and introduce the Enum TC class
X-Git-Tag: 0_55~229
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=dabed765f61b9f85c133dfabd885b1d6cd3b1d52;p=gitmo%2FMoose.git

fix and test equals for various TC classes, and introduce the Enum TC class
---

diff --git a/lib/Moose/Meta/TypeConstraint.pm b/lib/Moose/Meta/TypeConstraint.pm
index 618b6b4..cc12df9 100644
--- a/lib/Moose/Meta/TypeConstraint.pm
+++ b/lib/Moose/Meta/TypeConstraint.pm
@@ -10,7 +10,7 @@ use overload '""'     => sub { shift->name },   # stringify to tc name
 
 use Sub::Name    'subname';
 use Carp         'confess';
-use Scalar::Util 'blessed';
+use Scalar::Util qw(blessed refaddr);
 
 our $VERSION   = '0.12';
 our $AUTHORITY = 'cpan:STEVAN';
@@ -91,19 +91,24 @@ sub get_message {
 sub equals {
     my ( $self, $type_or_name ) = @_;
 
-    my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
+    my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
+
+    return 1 if refaddr($self) == refaddr($other);
+
+    if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) {
+        return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint;
+    }
+
+    return unless $self->constraint == $other->constraint;
+
+    if ( $self->has_parent ) {
+        return unless $other->has_parent;
+        return unless $self->parent->equals( $other->parent );
+    } else {
+        return if $other->has_parent;
+    }
 
-    # this is so utterly broken
-    # any anon type constraint equals any other, because their names are both '__ANON__'
-    # I think the correct implementation is:
-    # refaddr == refaddr
-    #  ||
-    # constraint_coderef == constraint_coderef && parent->equals(parent)
-    # but we need tests first
-    # the Enum constraint can compare it's elements in a subclass
-    # refaddr eq will DWIM for all registered types
-    # the Class tc will already do the right thing even if the name is different
-    $self->name eq $type->name;
+    return 1;
 }
 
 sub is_a_type_of {
diff --git a/lib/Moose/Meta/TypeConstraint/Class.pm b/lib/Moose/Meta/TypeConstraint/Class.pm
index ef2970a..a094aae 100644
--- a/lib/Moose/Meta/TypeConstraint/Class.pm
+++ b/lib/Moose/Meta/TypeConstraint/Class.pm
@@ -25,12 +25,19 @@ sub new {
 
     my $self  = $class->meta->new_object(%args);
 
-    $self->compile_type_constraint()
-        unless $self->_has_compiled_type_constraint;
+    $self->_create_hand_optimized_type_constraint;
+
+    $self->compile_type_constraint();
 
     return $self;
 }
 
+sub _create_hand_optimized_type_constraint {
+    my $self = shift;
+    my $class = $self->class;
+    $self->hand_optimized_type_constraint(sub { blessed( $_[0] ) && $_[0]->isa($class) });
+}
+
 sub parents {
     my $self = shift;
     return (
@@ -46,24 +53,14 @@ sub parents {
     );
 }
 
-sub hand_optimized_type_constraint {
-    my $self  = shift;
-    my $class = $self->class;
-    sub { blessed( $_[0] ) && $_[0]->isa($class) }
-}
-
-sub has_hand_optimized_type_constraint { 1 }
-
 sub equals {
     my ( $self, $type_or_name ) = @_;
 
-    my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
+    my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
 
-    if ( $type->isa(__PACKAGE__) ) {
-        return $self->class eq $type->class;
-    } else {
-        $self->SUPER::equals($type);
-    }
+    return unless $other->isa(__PACKAGE__);
+
+    return $self->class eq $other->class;
 }
 
 sub is_a_type_of {
diff --git a/lib/Moose/Meta/TypeConstraint/Enum.pm b/lib/Moose/Meta/TypeConstraint/Enum.pm
new file mode 100644
index 0000000..c823040
--- /dev/null
+++ b/lib/Moose/Meta/TypeConstraint/Enum.pm
@@ -0,0 +1,95 @@
+#!/usr/bin/perl
+
+package Moose::Meta::TypeConstraint::Enum;
+
+use strict;
+use warnings;
+use metaclass;
+
+our $VERSION   = '0.06';
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Moose::Meta::TypeConstraint';
+
+__PACKAGE__->meta->add_attribute('values' => (
+    accessor  => 'values',
+));
+
+sub new {
+    my ( $class, %args ) = @_;
+
+    $args{parent} = Moose::Util::TypeConstraints::find_type_constraint('Str');
+
+    my $self = $class->meta->new_object(%args);
+
+    $self->compile_type_constraint()
+        unless $self->_has_compiled_type_constraint;
+
+    return $self;
+}
+
+sub equals {
+    my ( $self, $type_or_name ) = @_;
+
+    my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
+
+    return unless $other->isa(__PACKAGE__);
+
+    my @self_values  = sort @{ $self->values };
+    my @other_values = sort @{ $other->values };
+
+    return unless @self_values == @other_values;
+
+    while ( @self_values ) {
+        my $value = shift @self_values;
+        my $other_value = shift @other_values;
+
+        return unless $value eq $other_value;
+    }
+
+    return 1;
+}
+
+sub constraint {
+    my $self = shift;
+
+    my %values = map { $_ => undef } @{ $self->values };
+
+    return sub { exists $values{$_[0]} };
+}
+
+sub _compile_hand_optimized_type_constraint {
+    my $self  = shift;
+
+    my %values = map { $_ => undef } @{ $self->values };
+
+    sub { defined($_[0]) && !ref($_[0]) && exists $values{$_[0]} };
+}
+
+__PACKAGE__
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::TypeConstraint::Enum - Type constraint for enumerated values.
+
+=head1 METHODS
+
+=over 4
+
+=item B<new>
+
+=item B<equals>
+
+=item B<constraint>
+
+=item B<values>
+
+=back
+
+=cut
+
+
diff --git a/lib/Moose/Meta/TypeConstraint/Parameterized.pm b/lib/Moose/Meta/TypeConstraint/Parameterized.pm
index 7bbc54a..5867914 100644
--- a/lib/Moose/Meta/TypeConstraint/Parameterized.pm
+++ b/lib/Moose/Meta/TypeConstraint/Parameterized.pm
@@ -18,6 +18,20 @@ __PACKAGE__->meta->add_attribute('type_parameter' => (
     predicate => 'has_type_parameter',
 ));
 
+sub equals {
+    my ( $self, $type_or_name ) = @_;
+
+    my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
+
+    return unless $other->isa(__PACKAGE__);
+    
+    return (
+        $self->type_parameter->equals( $other->type_parameter )
+            and
+        $self->parent->equals( $other->parent )
+    );
+}
+
 sub compile_type_constraint {
     my $self = shift;
     
@@ -65,6 +79,8 @@ Moose::Meta::TypeConstraint::Parameterized - Higher Order type constraints for M
 
 =item B<meta>
 
+=item B<equals>
+
 =back
 
 =head1 BUGS
diff --git a/lib/Moose/Meta/TypeConstraint/Union.pm b/lib/Moose/Meta/TypeConstraint/Union.pm
index 0f538e3..57c4e80 100644
--- a/lib/Moose/Meta/TypeConstraint/Union.pm
+++ b/lib/Moose/Meta/TypeConstraint/Union.pm
@@ -40,6 +40,36 @@ sub new {
     return $self;
 }
 
+sub equals {
+    my ( $self, $type_or_name ) = @_;
+
+    my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name);
+
+    return unless $other->isa(__PACKAGE__);
+
+    my @self_constraints  = @{ $self->type_constraints };
+    my @other_constraints = @{ $other->type_constraints };
+
+    return unless @self_constraints == @other_constraints;
+
+    # FIXME presort type constraints for efficiency?
+    constraint: foreach my $constraint ( @self_constraints ) {
+        for ( my $i = 0; $i < @other_constraints; $i++ ) {
+            if ( $constraint->equals($other_constraints[$i]) ) {
+                splice @other_constraints, $i, 1;
+                next constraint;
+            }
+        }
+    }
+
+    return @other_constraints == 0;
+}
+
+sub parents {
+    my $self = shift;
+    $self->type_constraints;
+}
+
 sub validate {
     my ($self, $value) = @_;
     my $message;
@@ -101,10 +131,14 @@ but it does provide the same API
 
 =item B<type_constraints>
 
+=item B<parents>
+
 =item B<constraint>
 
 =item B<includes_type>
 
+=item B<equals>
+
 =back
 
 =head2 Overriden methods 
diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm
index 73ecf48..39ce45d 100644
--- a/lib/Moose/Util/TypeConstraints.pm
+++ b/lib/Moose/Util/TypeConstraints.pm
@@ -25,6 +25,7 @@ sub find_or_create_type_constraint       ($;$);
 sub create_type_constraint_union         (@);
 sub create_parameterized_type_constraint ($);
 sub create_class_type_constraint         ($;$);
+sub create_enum_type_constraint          ($$);
 #sub create_class_type_constraint         ($);
 
 # dah sugah!
@@ -50,6 +51,7 @@ use Moose::Meta::TypeConstraint;
 use Moose::Meta::TypeConstraint::Union;
 use Moose::Meta::TypeConstraint::Parameterized;
 use Moose::Meta::TypeConstraint::Parameterizable;
+use Moose::Meta::TypeConstraint::Enum;
 use Moose::Meta::TypeCoercion;
 use Moose::Meta::TypeCoercion::Union;
 use Moose::Meta::TypeConstraint::Registry;
@@ -165,6 +167,7 @@ sub create_class_type_constraint ($;$) {
       $message = $_[0]->{message} if exists $_[0]->{message};
     }
 
+    # FIXME allow a different name too, and potentially handle anon
     Moose::Meta::TypeConstraint::Class->new(
         name => $class,
         ($message ? (message => $message) : ())
@@ -227,6 +230,7 @@ sub register_type_constraint ($) {
     my $constraint = shift;
     confess "can't register an unnamed type constraint" unless defined $constraint->name;
     $REGISTRY->add_type_constraint($constraint);
+    return $constraint;
 }
 
 # type constructors
@@ -285,10 +289,21 @@ sub enum ($;@) {
     (scalar @values >= 2)
         || confess "You must have at least two values to enumerate through";
     my %valid = map { $_ => 1 } @values;
-    _create_type_constraint(
-        $type_name,
-        'Str',
-        sub { $valid{$_} }
+
+    register_type_constraint(
+        create_enum_type_constraint(
+            $type_name,
+            \@values,
+        )
+    );
+}
+
+sub create_enum_type_constraint ($$) {
+    my ( $type_name, $values ) = @_;
+    
+    Moose::Meta::TypeConstraint::Enum->new(
+        name   => $type_name || '__ANON__',
+        values => $values,
     );
 }
 
@@ -533,9 +548,10 @@ $REGISTRY->add_type_constraint(
         optimized            => \&Moose::Util::TypeConstraints::OptimizedConstraints::ArrayRef,
         constraint_generator => sub {
             my $type_parameter = shift;
+            my $check = $type_parameter->_compiled_type_constraint;
             return sub {
                 foreach my $x (@$_) {
-                    ($type_parameter->check($x)) || return
+                    ($check->($x)) || return
                 } 1;
             }
         }
@@ -551,9 +567,10 @@ $REGISTRY->add_type_constraint(
         optimized            => \&Moose::Util::TypeConstraints::OptimizedConstraints::HashRef,
         constraint_generator => sub {
             my $type_parameter = shift;
+            my $check = $type_parameter->_compiled_type_constraint;
             return sub {
                 foreach my $x (values %$_) {
-                    ($type_parameter->check($x)) || return
+                    ($check->($x)) || return
                 } 1;
             }
         }
@@ -568,8 +585,9 @@ $REGISTRY->add_type_constraint(
         constraint           => sub { 1 },
         constraint_generator => sub {
             my $type_parameter = shift;
+            my $check = $type_parameter->_compiled_type_constraint;
             return sub {
-                return 1 if not(defined($_)) || $type_parameter->check($_);
+                return 1 if not(defined($_)) || $check->($_);
                 return;
             }
         }
@@ -876,6 +894,8 @@ L<Moose::Meta::TypeConstraint::Parameterized> for it.
 Given a class name it will create a new L<Moose::Meta::TypeConstraint::Class>
 object for that class name.
 
+=item B<create_enum_type_constraint ($name, $values)>
+
 =item B<find_or_create_type_constraint ($type_name, ?$options_for_anon_type)>
 
 This will attempt to find or create a type constraint given the a C<$type_name>.
diff --git a/t/040_type_constraints/008_union_types.t b/t/040_type_constraints/008_union_types.t
index 5ccf213..c548a6d 100644
--- a/t/040_type_constraints/008_union_types.t
+++ b/t/040_type_constraints/008_union_types.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 27;
+use Test::More tests => 33;
 use Test::Exception;
 
 BEGIN {
@@ -27,6 +27,14 @@ isa_ok($Str_or_Undef, 'Moose::Meta::TypeConstraint::Union');
 ok($Str_or_Undef->check(undef), '... (Str | Undef) can accept an Undef value');
 ok($Str_or_Undef->check('String'), '... (Str | Undef) can accept a String value');
 
+ok($Str_or_Undef->is_a_type_of($Str), "subtype of Str");
+ok($Str_or_Undef->is_a_type_of($Undef), "subtype of Undef");
+
+ok( !$Str_or_Undef->equals($Str), "not equal to Str" );
+ok( $Str_or_Undef->equals($Str_or_Undef), "equal to self" );
+ok( $Str_or_Undef->equals(Moose::Meta::TypeConstraint::Union->new(type_constraints => [ $Str, $Undef ])), "equal to clone" );
+ok( $Str_or_Undef->equals(Moose::Meta::TypeConstraint::Union->new(type_constraints => [ $Undef, $Str ])), "equal to reversed clone" );
+
 # another ....
 
 my $ArrayRef = find_type_constraint('ArrayRef');
diff --git a/t/040_type_constraints/015_enum.t b/t/040_type_constraints/015_enum.t
index a0b7851..2aebf75 100644
--- a/t/040_type_constraints/015_enum.t
+++ b/t/040_type_constraints/015_enum.t
@@ -31,7 +31,7 @@ push @invalid_metacharacters, '^1?$|^(11+?)\1+$';
 plan tests => @valid_letters        + @invalid_letters
             + @valid_languages      + @invalid_languages
             + @valid_metacharacters + @invalid_metacharacters
-            + @valid_languages      + 3;
+            + @valid_languages      + 6;
 
 Moose::Util::TypeConstraints->export_type_constraints_as_functions();
 
@@ -56,4 +56,6 @@ is($anon_enum->parent->name, 'Str', '... got the right parent name');
 ok($anon_enum->check($_), "'$_' is a language") for @valid_languages;
 
 
-
+ok( !$anon_enum->equals( enum [qw(foo bar)] ), "doesn't equal a diff enum" );
+ok( $anon_enum->equals( $anon_enum ), "equals itself" );
+ok( $anon_enum->equals( enum \@valid_languages ), "equals duplicate" );
diff --git a/t/040_type_constraints/016_subtyping_parameterized_types.t b/t/040_type_constraints/016_subtyping_parameterized_types.t
index 2462c14..5c94290 100644
--- a/t/040_type_constraints/016_subtyping_parameterized_types.t
+++ b/t/040_type_constraints/016_subtyping_parameterized_types.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 18;
+use Test::More tests => 21;
 use Test::Exception;
 
 BEGIN {
@@ -28,6 +28,10 @@ lives_ok {
 
     ok($t->check({ one => 1, two => 2 }), '... validated it correctly');
     ok(!$t->check({ one => "ONE", two => "TWO" }), '... validated it correctly');
+
+    ok( $t->equals($t), "equals to self" );
+    ok( !$t->equals( $t->parent ), "not equal to parent" );
+    ok( $t->parent->equals( $t->parent ), "parent equals to self" );
 }
 
 lives_ok {
diff --git a/t/040_type_constraints/018_custom_parameterized_types.t b/t/040_type_constraints/018_custom_parameterized_types.t
index da19c8f..54de87d 100644
--- a/t/040_type_constraints/018_custom_parameterized_types.t
+++ b/t/040_type_constraints/018_custom_parameterized_types.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 21;
+use Test::More tests => 28;
 use Test::Exception;
 
 BEGIN {
@@ -43,6 +43,9 @@ lives_ok {
 
     ok($t->check({ one => 1, two => 2 }), '... validated it correctly');
     ok(!$t->check({ one1 => 1, two2 => 2 }), '... validated it correctly');
+
+    ok( $t->equals($t), "equals to self" );
+    ok( !$t->equals($t->parent), "not equal to parent" );
 }
 
 my $hoi = Moose::Util::TypeConstraints::find_or_create_type_constraint('AlphaKeyHash[Int]');
@@ -52,6 +55,12 @@ 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');
 
+ok( $hoi->equals($hoi), "equals to self" );
+ok( !$hoi->equals($hoi->parent), "equals to self" );
+ok( !$hoi->equals(find_type_constraint('AlphaKeyHash')), "not equal to unparametrized self" );
+ok( $hoi->equals( Moose::Meta::TypeConstraint::Parameterized->new( name => "Blah", parent => find_type_constraint("AlphaKeyHash"), type_parameter => find_type_constraint("Int") ) ), "equal to clone" );
+ok( !$hoi->equals( Moose::Meta::TypeConstraint::Parameterized->new( name => "Oink", parent => find_type_constraint("AlphaKeyHash"), type_parameter => find_type_constraint("Str") ) ), "not equal to different parameter" );
+
 my $th = Moose::Util::TypeConstraints::find_or_create_type_constraint('Trihash[Bool]');
 
 ok(!$th->check({ one => 1, two => 1 }), '... validated it correctly');
diff --git a/t/040_type_constraints/021_maybe_type_constraint.t b/t/040_type_constraints/021_maybe_type_constraint.t
index e59f501..515610c 100644
--- a/t/040_type_constraints/021_maybe_type_constraint.t
+++ b/t/040_type_constraints/021_maybe_type_constraint.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 12;
+use Test::More tests => 19;
 use Test::Exception;
 
 BEGIN {
@@ -15,6 +15,14 @@ my $type = Moose::Util::TypeConstraints::find_or_create_type_constraint('Maybe[I
 isa_ok($type, 'Moose::Meta::TypeConstraint');
 isa_ok($type, 'Moose::Meta::TypeConstraint::Parameterized');
 
+ok( $type->equals($type), "equals self" );
+ok( !$type->equals($type->parent), "not equal to parent" );
+ok( !$type->equals(find_type_constraint("Maybe")), "not equal to Maybe" );
+ok( $type->parent->equals(find_type_constraint("Maybe")), "parent is Maybe" );
+ok( $type->equals( Moose::Meta::TypeConstraint::Parameterized->new( name => "__ANON__", parent => find_type_constraint("Maybe"), type_parameter => find_type_constraint("Int") ) ), "equal to clone" );
+ok( !$type->equals( Moose::Meta::TypeConstraint::Parameterized->new( name => "__ANON__", parent => find_type_constraint("Maybe"), type_parameter => find_type_constraint("Str") ) ), "not equal to clone with diff param" );
+ok( !$type->equals( Moose::Util::TypeConstraints::find_or_create_type_constraint('Maybe[Str]') ), "not equal to declarative version of diff param" );
+
 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)');