There's no need ot expose Parameterizable's ->parse_type_constraint

[gitmo/Moose.git] / lib / Moose / Util / TypeConstraints.pm

diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm
index f8ccabe..39e2acf 100644 (file)
--- a/lib/Moose/Util/TypeConstraints.pm
+++ b/lib/Moose/Util/TypeConstraints.pm
@@ -101,37 +101,32 @@ sub create_type_constraint_union (@) {
     else {
         @type_constraint_names = @_;
     }
-
+    
     (scalar @type_constraint_names >= 2)
         || Moose->throw_error("You must pass in at least 2 type names to make a union");
 
-    ($REGISTRY->has_type_constraint($_))
-        || Moose->throw_error("Could not locate type constraint ($_) for the union")
-            foreach @type_constraint_names;
-
+    my @type_constraints = sort {$a->name cmp $b->name} map {
+        find_or_parse_type_constraint($_) ||
+         Moose->throw_error("Could not locate type constraint ($_) for the union");
+    } @type_constraint_names;
+    
     return Moose::Meta::TypeConstraint::Union->new(
-        type_constraints => [
-            map {
-                $REGISTRY->get_type_constraint($_)
-            } @type_constraint_names
-        ],
+        type_constraints => \@type_constraints
     );
 }
 
 sub create_parameterized_type_constraint ($) {
     my $type_constraint_name = shift;
+    my ($base_type, $type_parameter) = _parse_parameterized_type_constraint($type_constraint_name);
 
-    my ($base_type, $type_parameter_str) = _parse_parameterized_type_constraint($type_constraint_name);
-
-    (defined $base_type && defined $type_parameter_str)
+    (defined $base_type && defined $type_parameter)
         || Moose->throw_error("Could not parse type name ($type_constraint_name) correctly");
 
     if ($REGISTRY->has_type_constraint($base_type)) {
         my $base_type_tc = $REGISTRY->get_type_constraint($base_type);
         return _create_parameterized_type_constraint(
-            $type_constraint_name,
             $base_type_tc,
-            $type_parameter_str,
+            $type_parameter,
         );
     } else {
         Moose->throw_error("Could not locate the base type ($base_type)");
@@ -139,17 +134,18 @@ sub create_parameterized_type_constraint ($) {
 }
 
 sub _create_parameterized_type_constraint {
-    my ($tc_name, $base_type_tc, $type_parameter_str) = @_;
-    if($base_type_tc->can('parameterize')) {
-        my @type_parameters_tc = $base_type_tc->parse_parameter_str($type_parameter_str);  
-        return $base_type_tc->parameterize($tc_name,@type_parameters_tc);
-    } else {
+    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           => $tc_name,
-            parent         => $base_type_tc,
-            type_parameter => find_or_create_isa_type_constraint[$type_parameter_str],
+            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?
@@ -228,23 +224,29 @@ sub find_or_create_does_type_constraint ($) {
 }
 
 sub find_or_parse_type_constraint ($) {
-    my $type_constraint_name = shift;
+    my $type_constraint_name = normalize_type_constraint_name(shift);
     my $constraint;
     
     if ($constraint = find_type_constraint($type_constraint_name)) {
         return $constraint;
     } elsif (_detect_type_constraint_union($type_constraint_name)) {
         $constraint = create_type_constraint_union($type_constraint_name);
-    } elsif (_detect_parameterized_type_constraint($type_constraint_name)) {     
+    } elsif (_detect_parameterized_type_constraint($type_constraint_name)) {
         $constraint = create_parameterized_type_constraint($type_constraint_name);
     } else {
         return;
     }
-    
+
     $REGISTRY->add_type_constraint($constraint);
     return $constraint;
 }
 
+sub normalize_type_constraint_name {
+    my $type_constraint_name = shift @_;
+    $type_constraint_name =~ s/\s//g;
+    return $type_constraint_name;
+}
+
 ## --------------------------------------------------------
 ## exported functions ...
 ## --------------------------------------------------------
@@ -452,19 +454,26 @@ sub _install_type_coercions ($$) {
 
     my $any;
 
-    my $type                = qr{  $valid_chars+  (?: \[  (??{$any})  \] )? }x;
-    my $type_capture_parts  = qr{ ($valid_chars+) (?: \[ ((??{$any})) \] )? }x;
-    my $type_with_parameter = qr{  $valid_chars+      \[  (??{$any})  \]    }x;
+    my $type                = qr{  $valid_chars+  (?: \[  \s* (??{$any}) \s* \] )? }x;
+    my $type_capture_parts  = qr{ ($valid_chars+) (?: \[ \s* ((??{$any})) \s* \] )? }x;
+    my $type_with_parameter = qr{  $valid_chars+      \[ \s* (??{$any}) \s* \]    }x;
 
     my $op_union = qr{ \s* \| \s* }x;
     my $union    = qr{ $type (?: $op_union $type )+ }x;
 
-    $any = qr{ $type | $union }x;
+    ## New Stuff for structured types.
+    my $comma = qr{,};
+    my $indirection = qr{=>};
+    my $divider_ops = qr{ $comma | $indirection }x;
+    my $structure_divider = qr{\s* $divider_ops \s*}x;    
+    my $structure_elements = qr{ ($type $structure_divider*)+ }x;
+
+    $any = qr{ $type | $union | $structure_elements }x;
 
     sub _parse_parameterized_type_constraint {
         { no warnings 'void'; $any; } # force capture of interpolated lexical
-        $_[0] =~ m{ $type_capture_parts }x;
-        return ($1, $2);
+        my($base, $elements) = ($_[0] =~ m{ $type_capture_parts }x);
+        return ($base,$elements);
     }
 
     sub _detect_parameterized_type_constraint {
@@ -924,6 +933,11 @@ This is just sugar for the type coercion construction syntax.
 
 =over 4
 
+=item B<normalize_type_constraint_name ($type_constraint_name)>
+
+Given a string that is expected to match a type constraint, will normalize the
+string so that extra whitespace and newlines are removed.
+
 =item B<create_type_constraint_union ($pipe_seperated_types | @type_constraint_names)>
 
 Given string with C<$pipe_seperated_types> or a list of C<@type_constraint_names>,