From: Dave Rolsky <autarch@urth.org>
Date: Sun, 10 Apr 2011 16:20:09 +0000 (-0500)
Subject: Add tests for un-parameterized Maybe
X-Git-Tag: 2.0100~82
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7fb4b360f565be7d6dc40c4b2f0d9fc0f6263bc7;p=gitmo%2FMoose.git

Add tests for un-parameterized Maybe

Add inlining for parameterizable types - add infrastructure for inlining parameterized, but it needs tests
---

diff --git a/lib/Moose/Meta/TypeConstraint/Parameterizable.pm b/lib/Moose/Meta/TypeConstraint/Parameterizable.pm
index 0db8126..1e050f3 100644
--- a/lib/Moose/Meta/TypeConstraint/Parameterizable.pm
+++ b/lib/Moose/Meta/TypeConstraint/Parameterizable.pm
@@ -13,6 +13,11 @@ __PACKAGE__->meta->add_attribute('constraint_generator' => (
     predicate => 'has_constraint_generator',
 ));
 
+__PACKAGE__->meta->add_attribute('inline_generator' => (
+    accessor  => 'inline_generator',
+    predicate => 'has_inline_generator',
+));
+
 sub generate_constraint_for {
     my ($self, $type) = @_;
 
@@ -63,9 +68,10 @@ sub parameterize {
     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,
+            name               => $tc_name,
+            parent             => $self,
+            type_parameter     => $contained_tc,
+            parameterized_from => $self,
         );
     }
     else {
diff --git a/lib/Moose/Meta/TypeConstraint/Parameterized.pm b/lib/Moose/Meta/TypeConstraint/Parameterized.pm
index 43078b6..70f0828 100644
--- a/lib/Moose/Meta/TypeConstraint/Parameterized.pm
+++ b/lib/Moose/Meta/TypeConstraint/Parameterized.pm
@@ -15,6 +15,11 @@ __PACKAGE__->meta->add_attribute('type_parameter' => (
     predicate => 'has_type_parameter',
 ));
 
+__PACKAGE__->meta->add_attribute('parameterized_from' => (
+    accessor   => 'parameterized_from',
+    predicate  => 'has_parameterized_from',
+));
+
 sub equals {
     my ( $self, $type_or_name ) = @_;
 
@@ -58,6 +63,23 @@ sub compile_type_constraint {
           . $self->parent->name . " doesn't subtype or coerce from a parameterizable type.");
 }
 
+sub has_inlined_type_constraint {
+    my $self = shift;
+
+    return $self->has_parameterized_from
+        && $self->has_parameterized_from->has_inline_generator;
+}
+
+sub _inline_check {
+    my $self = shift;
+
+    return
+        unless $self->has_parameterized_from
+            && $self->has_parameterized_from->has_inline_generator;
+
+    return $self->parameterized_from->generate_inline_for( $self->type, @_ );
+}
+
 sub create_child_type {
     my ($self, %opts) = @_;
     return Moose::Meta::TypeConstraint::Parameterizable->new(%opts, parent=>$self);
diff --git a/lib/Moose/Util/TypeConstraints/Builtins.pm b/lib/Moose/Util/TypeConstraints/Builtins.pm
index c651b55..761bfd3 100644
--- a/lib/Moose/Util/TypeConstraints/Builtins.pm
+++ b/lib/Moose/Util/TypeConstraints/Builtins.pm
@@ -3,6 +3,7 @@ package Moose::Util::TypeConstraints::Builtins;
 use strict;
 use warnings;
 
+use List::MoreUtils ();
 use Scalar::Util qw( blessed looks_like_number reftype );
 
 sub type { goto &Moose::Util::TypeConstraints::type }
@@ -152,7 +153,14 @@ sub define_builtins {
                 return sub {
                     return $check->( ${$_} );
                 };
-            }
+            },
+            inlined => sub {qq{ref $_[0] eq 'SCALAR' || ref $_[0] eq 'REF'}},
+            inline_generator => sub {
+                my $type_parameter = shift;
+                my $val            = shift;
+                return $type_parameter->_inline_check(
+                    '${ (' . $val . ') }' );
+            },
         )
     );
 
@@ -173,7 +181,16 @@ sub define_builtins {
                     }
                     1;
                     }
-            }
+            },
+            inlined          => sub {qq{ref $_[0] eq 'ARRAY'}},
+            inline_generator => sub {
+                my $type_parameter = shift;
+                my $val            = shift;
+                return
+                      '&List::MoreUtils::all( sub { '
+                    . $type_parameter->_inline_check('$_')
+                    . " }, \@{$val} )";
+            },
         )
     );
 
@@ -194,7 +211,16 @@ sub define_builtins {
                     }
                     1;
                     }
-            }
+            },
+            inlined          => sub {qq{ref $_[0] eq 'HASH'}},
+            inline_generator => sub {
+                my $type_parameter = shift;
+                my $val            = shift;
+                return
+                      '&List::MoreUtils::all( sub { '
+                    . $type_parameter->_inline_check('$_')
+                    . " }, values \%{$val} )";
+            },
         )
     );
 
@@ -212,7 +238,15 @@ sub define_builtins {
                     return 1 if not( defined($_) ) || $check->($_);
                     return;
                     }
-            }
+            },
+            inlined          => sub {'1'},
+            inline_generator => sub {
+                my $type_parameter = shift;
+                my $val            = shift;
+                return
+                    "(! defined $val) || ("
+                    . $type_parameter->_inline_check($val) . ')';
+            },
         )
     );
 }
diff --git a/t/type_constraints/util_std_type_constraints.t b/t/type_constraints/util_std_type_constraints.t
index 6139bbe..461c453 100644
--- a/t/type_constraints/util_std_type_constraints.t
+++ b/t/type_constraints/util_std_type_constraints.t
@@ -196,6 +196,32 @@ my %tests = (
             $OBJECT,
         ],
     },
+    Maybe => {
+        accept => [
+            $ZERO,
+            $ONE,
+            $INT,
+            $NEG_INT,
+            $NUM,
+            $NEG_NUM,
+            $EMPTY_STRING,
+            $STRING,
+            $NUM_IN_STRING,
+            $SCALAR_REF,
+            $SCALAR_REF_REF,
+            $ARRAY_REF,
+            $HASH_REF,
+            $CODE_REF,
+            $GLOB,
+            $GLOB_REF,
+            $FH,
+            $FH_OBJECT,
+            $REGEX,
+            $REGEX_OBJ,
+            $OBJECT,
+            $UNDEF,
+        ],
+    },
     Value => {
         accept => [
             $ZERO,