Implement type parameterization in XS

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

diff --git a/lib/Mouse/Util/TypeConstraints.pm b/lib/Mouse/Util/TypeConstraints.pm
index be539b0..9658ca5 100644 (file)
--- a/lib/Mouse/Util/TypeConstraints.pm
+++ b/lib/Mouse/Util/TypeConstraints.pm
@@ -2,7 +2,7 @@ package Mouse::Util::TypeConstraints;
 use Mouse::Util qw(does_role not_supported); # enables strict and warnings
 
 use Carp qw(confess);
-use Scalar::Util qw/blessed looks_like_number openhandle/;
+use Scalar::Util ();
 
 use Mouse::Meta::TypeConstraint;
 use Mouse::Exporter;
@@ -18,9 +18,9 @@ Mouse::Exporter->setup_import_methods(
 
 my %TYPE;
 
-sub as          ($) { (as => $_[0]) }
-sub where       (&) { (where => $_[0]) }
-sub message     (&) { (message => $_[0]) }
+sub as          ($) { (as          => $_[0]) }
+sub where       (&) { (where       => $_[0]) }
+sub message     (&) { (message     => $_[0]) }
 sub optimize_as (&) { (optimize_as => $_[0]) }
 
 sub from    { @_ }
@@ -151,30 +151,22 @@ sub coerce {
 }
 
 sub class_type {
-    my($name, $conf) = @_;
-    if ($conf && $conf->{class}) {
-        # No, you're using this wrong
-        warn "class_type() should be class_type(ClassName). Perhaps you're looking for subtype $name => as '$conf->{class}'?";
-        _create_type 'type', $name => (
-            as   => $conf->{class},
-
-            type => 'Class',
-       );
-    }
-    else {
-        _create_type 'type', $name => (
-            optimized_as => sub { blessed($_[0]) && $_[0]->isa($name) },
+    my($name, $options) = @_;
+    my $class = $options->{class} || $name;
+    return _create_type 'subtype', $name => (
+        as           => 'Object',
+        optimized_as => Mouse::Util::generate_isa_predicate_for($class),
 
-            type => 'Class',
-        );
-    }
+        type => 'Class',
+    );
 }
 
 sub role_type {
-    my($name, $conf) = @_;
-    my $role = ($conf && $conf->{role}) ? $conf->{role} : $name;
-    _create_type 'type', $name => (
-        optimized_as => sub { blessed($_[0]) && does_role($_[0], $role) },
+    my($name, $options) = @_;
+    my $role = $options->{role} || $name;
+    return _create_type 'subtype', $name => (
+        as           => 'Object',
+        optimized_as => sub { Scalar::Util::blessed($_[0]) && does_role($_[0], $role) },
 
         type => 'Role',
     );
@@ -214,102 +206,40 @@ sub _find_or_create_regular_type{
 
     return $TYPE{$spec} if exists $TYPE{$spec};
 
-    my $meta  = Mouse::Util::get_metaclass_by_name($spec);
+    my $meta = Mouse::Util::get_metaclass_by_name($spec)
+        or return undef;
 
-    if(!$meta){
-        return;
-    }
-
-    my $check;
-    my $type;
-    if($meta->isa('Mouse::Meta::Role')){
-        $check = sub{
-            return blessed($_[0]) && $_[0]->does($spec);
-        };
-        $type = 'Role';
+    if(Mouse::Util::is_a_metarole($meta)){
+        return role_type($spec);
     }
     else{
-        $check = sub{
-            return blessed($_[0]) && $_[0]->isa($spec);
-        };
-        $type = 'Class';
+        return class_type($spec);
     }
-
-    return $TYPE{$spec} = Mouse::Meta::TypeConstraint->new(
-        name      => $spec,
-        optimized => $check,
-
-        type      => $type,
-    );
 }
 
-$TYPE{ArrayRef}{constraint_generator} = sub {
-    my($type_parameter) = @_;
-    my $check = $type_parameter->_compiled_type_constraint;
-
-    return sub{
-        foreach my $value (@{$_}) {
-            return undef unless $check->($value);
-        }
-        return 1;
-    }
-};
-$TYPE{HashRef}{constraint_generator} = sub {
-    my($type_parameter) = @_;
-    my $check = $type_parameter->_compiled_type_constraint;
-
-    return sub{
-        foreach my $value(values %{$_}){
-            return undef unless $check->($value);
-        }
-        return 1;
-    };
-};
-
-# 'Maybe' type accepts 'Any', so it requires parameters
-$TYPE{Maybe}{constraint_generator} = sub {
-    my($type_parameter) = @_;
-    my $check = $type_parameter->_compiled_type_constraint;
-
-    return sub{
-        return !defined($_) || $check->($_);
-    };
-};
+$TYPE{ArrayRef}{constraint_generator} = \&_parameterize_ArrayRef_for;
+$TYPE{HashRef}{constraint_generator}  = \&_parameterize_HashRef_for;
+$TYPE{Maybe}{constraint_generator}    = \&_parameterize_Maybe_for;
 
 sub _find_or_create_parameterized_type{
     my($base, $param) = @_;
 
     my $name = sprintf '%s[%s]', $base->name, $param->name;
 
-    $TYPE{$name} ||= do{
-        my $generator = $base->{constraint_generator};
-
-        if(!$generator){
-            confess("The $name constraint cannot be used, because $param doesn't subtype from a parameterizable type");
-        }
-
-        Mouse::Meta::TypeConstraint->new(
-            name               => $name,
-            parent             => $base,
-            constraint         => $generator->($param),
-
-            type               => 'Parameterized',
-        );
-    }
+    $TYPE{$name} ||= $base->parameterize($param, $name);
 }
+
 sub _find_or_create_union_type{
-    my @types = sort{ $a cmp $b } map{ $_->{type_constraints} ? @{$_->{type_constraints}} : $_ } @_;
+    my @types = sort map{ $_->{type_constraints} ? @{$_->{type_constraints}} : $_ } @_;
 
     my $name = join '|', @types;
 
-    $TYPE{$name} ||= do{
-        return Mouse::Meta::TypeConstraint->new(
-            name              => $name,
-            type_constraints  => \@types,
+    $TYPE{$name} ||= Mouse::Meta::TypeConstraint->new(
+        name              => $name,
+        type_constraints  => \@types,
 
-            type              => 'Union',
-        );
-    };
+        type              => 'Union',
+    );
 }
 
 # The type parser
@@ -384,7 +314,7 @@ sub _parse_type{
 
 sub find_type_constraint {
     my($spec) = @_;
-    return $spec if blessed($spec) && $spec->isa('Mouse::Meta::TypeConstraint');
+    return $spec if Mouse::Util::is_a_type_constraint($spec);
 
     $spec =~ s/\s+//g;
     return $TYPE{$spec};
@@ -392,7 +322,7 @@ sub find_type_constraint {
 
 sub find_or_parse_type_constraint {
     my($spec) = @_;
-    return $spec if blessed($spec) && $spec->isa('Mouse::Meta::TypeConstraint');
+    return $spec if Mouse::Util::is_a_type_constraint($spec);
 
     $spec =~ s/\s+//g;
     return $TYPE{$spec} || do{
@@ -402,10 +332,12 @@ sub find_or_parse_type_constraint {
 }
 
 sub find_or_create_does_type_constraint{
+    # XXX: Moose does not register a new role_type, but Mouse does.
     return find_or_parse_type_constraint(@_) || role_type(@_);
 }
 
 sub find_or_create_isa_type_constraint {
+    # XXX: Moose does not register a new class_type, but Mouse does.
     return find_or_parse_type_constraint(@_) || class_type(@_);
 }
 
@@ -419,7 +351,7 @@ Mouse::Util::TypeConstraints - Type constraint system for Mouse
 
 =head1 VERSION
 
-This document describes Mouse version 0.40_01
+This document describes Mouse version 0.40_03
 
 =head2 SYNOPSIS