first pass at restoring parametrization changes and tests

diff --git a/lib/Moose/Meta/TypeConstraint/Parameterizable.pm b/lib/Moose/Meta/TypeConstraint/Parameterizable.pm
index bc3b9ce..f08f9c8 100644 (file)
--- a/lib/Moose/Meta/TypeConstraint/Parameterizable.pm
+++ b/lib/Moose/Meta/TypeConstraint/Parameterizable.pm
@@ -9,6 +9,8 @@ $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
 
 use base 'Moose::Meta::TypeConstraint';
+use Moose::Meta::TypeConstraint::Parameterized;
+use Moose::Util::TypeConstraints ();
 
 __PACKAGE__->meta->add_attribute('constraint_generator' => (
     accessor  => 'constraint_generator',
@@ -40,6 +42,29 @@ sub _can_coerce_constraint_from {
     };
 }
 
+sub _parse_type_parameter {
+    my ($self, $type_parameter) = @_;
+    return Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($type_parameter);
+}
+
+sub parameterize {
+    my ($self, $type_parameter) = @_;
+
+    my $contained_tc = $self->_parse_type_parameter($type_parameter);
+
+    if ( $contained_tc->isa('Moose::Meta::TypeConstraint') ) {
+        my $tc_name = $self->name . '[' . $contained_tc->name . ']';
+        return Moose::Meta::TypeConstraint::Parameterized->new(
+            name           => $tc_name,
+            parent         => $self,
+            type_parameter => $contained_tc,
+        );
+    }
+    else {
+        Moose->throw_error("The type parameter must be a Moose meta type");
+    }
+}
+
 
 1;
 
@@ -62,6 +87,11 @@ Moose::Meta::TypeConstraint::Parameterizable - Higher Order type constraints for
 
 =item B<generate_constraint_for>
 
+=item B<parameterize>
+
+Given a single type constraint string, this method parses the string
+and parameterizes the type based on the parsed string.
+
 =item B<meta>
 
 =back

diff --git a/lib/Moose/Meta/TypeConstraint/Union.pm b/lib/Moose/Meta/TypeConstraint/Union.pm
index 9479ccf..77a6917 100644 (file)
--- a/lib/Moose/Meta/TypeConstraint/Union.pm
+++ b/lib/Moose/Meta/TypeConstraint/Union.pm
@@ -21,7 +21,8 @@ __PACKAGE__->meta->add_attribute('type_constraints' => (
 sub new { 
     my ($class, %options) = @_;
     my $self = $class->SUPER::new(
-        name     => (join '|' => sort map { $_->name } @{$options{type_constraints}}),
+        name     => (join '|' => sort {$a cmp $b}
+                     map { $_->name } @{$options{type_constraints}}),
         parent   => undef,
         message  => undef,
         hand_optimized_type_constraint => undef,

diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm
index 0261004..a9c9310 100644 (file)
--- a/lib/Moose/Util/TypeConstraints.pm
+++ b/lib/Moose/Util/TypeConstraints.pm
@@ -103,22 +103,30 @@ sub create_parameterized_type_constraint {
     (defined $base_type && defined $type_parameter)
         || Moose->throw_error("Could not parse type name ($type_constraint_name) correctly");
 
-    # We need to get the relevant type constraints and use them to
-    # create the name to ensure that we end up with the fully
-    # normalized name, because the user could've passed something like
-    # HashRef[Str|Int] and we want to make that HashRef[Int|Str].
-    my $base_type_tc = $REGISTRY->get_type_constraint($base_type)
-        || Moose->throw_error("Could not locate the base type ($base_type)");
-    my $parameter_tc = find_or_create_isa_type_constraint($type_parameter)
-        || Moose->throw_error("Could not locate the parameter type ($type_parameter)");
-
-    return Moose::Meta::TypeConstraint::Parameterized->new(
-        name           => $base_type_tc->name . '[' . $parameter_tc->name . ']',
-        parent         => $base_type_tc,
-        type_parameter => $parameter_tc,
-    );
+    if ($REGISTRY->has_type_constraint($base_type)) {
+        my $base_type_tc = $REGISTRY->get_type_constraint($base_type);
+        return _create_parameterized_type_constraint(
+            $base_type_tc,
+            $type_parameter
+        );
+    } else {
+        Moose->throw_error("Could not locate the base type ($base_type)");
+    }
 }
 
+sub _create_parameterized_type_constraint {
+    my ( $base_type_tc, $type_parameter ) = @_;
+    if ( $base_type_tc->can('parameterize') ) {
+        return $base_type_tc->parameterize($type_parameter);
+    } else {
+        return Moose::Meta::TypeConstraint::Parameterized->new(
+            name => $base_type_tc->name . '[' . $type_parameter . ']',
+            parent => $base_type_tc,
+            type_parameter => find_or_create_isa_type_constraint($type_parameter),
+        );
+    }
+}                                       
+
 #should we also support optimized checks?
 sub create_class_type_constraint {
     my ( $class, $options ) = @_;

diff --git a/t/040_type_constraints/027_parameterize_from.t b/t/040_type_constraints/027_parameterize_from.t
new file mode 100644 (file)
index 0000000..f917e28
--- /dev/null
+++ b/t/040_type_constraints/027_parameterize_from.t
@@ -0,0 +1,79 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 12;
+use Test::Exception;
+
+BEGIN {
+    use_ok('Moose::Util::TypeConstraints');           
+}
+
+# testing the parameterize method
+
+{
+    my $parameterizable = subtype 'parameterizable_hashref', as 'HashRef';
+
+    my $parameterized = subtype 'parameterized_hashref', as 'HashRef[Int]';
+
+    my $int = Moose::Util::TypeConstraints::find_type_constraint('Int');
+
+    my $from_parameterizable = $parameterizable->parameterize($int);
+
+    isa_ok $parameterizable,
+        'Moose::Meta::TypeConstraint::Parameterizable', =>
+        'Got expected type instance';
+
+    package Test::Moose::Meta::TypeConstraint::Parameterizable;
+    use Moose;
+
+    has parameterizable      => ( is => 'rw', isa => $parameterizable );
+    has parameterized        => ( is => 'rw', isa => $parameterized );
+    has from_parameterizable => ( is => 'rw', isa => $from_parameterizable );
+}
+
+# Create and check a dummy object
+
+ok my $params = Test::Moose::Meta::TypeConstraint::Parameterizable->new() =>
+    'Create Dummy object for testing';
+
+isa_ok $params, 'Test::Moose::Meta::TypeConstraint::Parameterizable' =>
+    'isa correct type';
+
+# test parameterizable
+
+lives_ok sub {
+    $params->parameterizable( { a => 'Hello', b => 'World' } );
+} => 'No problem setting parameterizable';
+
+is_deeply $params->parameterizable,
+    { a => 'Hello', b => 'World' } => 'Got expected values';
+
+# test parameterized
+
+lives_ok sub {
+    $params->parameterized( { a => 1, b => 2 } );
+} => 'No problem setting parameterized';
+
+is_deeply $params->parameterized, { a => 1, b => 2 } => 'Got expected values';
+
+throws_ok sub {
+    $params->parameterized( { a => 'Hello', b => 'World' } );
+    }, qr/Attribute \(parameterized\) does not pass the type constraint/ =>
+    'parameterized throws expected error';
+
+# test from_parameterizable
+
+lives_ok sub {
+    $params->from_parameterizable( { a => 1, b => 2 } );
+} => 'No problem setting from_parameterizable';
+
+is_deeply $params->from_parameterizable,
+    { a => 1, b => 2 } => 'Got expected values';
+
+throws_ok sub {
+    $params->from_parameterizable( { a => 'Hello', b => 'World' } );
+    },
+    qr/Attribute \(from_parameterizable\) does not pass the type constraint/
+    => 'from_parameterizable throws expected error';