created a more introspective slurpy function, moved it to the tc class, and some...

[gitmo/MooseX-Types-Structured.git] / lib / MooseX / Meta / TypeConstraint / Structured.pm

diff --git a/lib/MooseX/Meta/TypeConstraint/Structured.pm b/lib/MooseX/Meta/TypeConstraint/Structured.pm
index dc45493..c15b647 100644 (file)
--- a/lib/MooseX/Meta/TypeConstraint/Structured.pm
+++ b/lib/MooseX/Meta/TypeConstraint/Structured.pm
@@ -2,6 +2,7 @@ package ## Hide from PAUSE
  MooseX::Meta::TypeConstraint::Structured;
 
 use Moose;
+use Devel::PartialDump;
 use Moose::Util::TypeConstraints ();
 use MooseX::Meta::TypeCoercion::Structured;
 extends 'Moose::Meta::TypeConstraint';
@@ -45,7 +46,11 @@ a set of type constraints.
 
 =cut
 
-has 'constraint_generator' => (is=>'ro', isa=>'CodeRef');
+has 'constraint_generator' => (
+    is=>'ro',
+    isa=>'CodeRef',
+    predicate=>'has_constraint_generator',
+);
 
 =head1 METHODS
 
@@ -76,8 +81,9 @@ of values (to be passed at check time)
 sub generate_constraint_for {
     my ($self, $type_constraints) = @_;
     return sub {
+        my (@args) = @_;
         my $constraint_generator = $self->constraint_generator;
-        return $constraint_generator->($type_constraints, @_);
+        return $constraint_generator->($type_constraints, @args);
     };
 }
 
@@ -88,20 +94,39 @@ Given a ref of type constraints, create a structured type.
 =cut
 
 sub parameterize {
+    
     my ($self, @type_constraints) = @_;
     my $class = ref $self;
     my $name = $self->name .'['. join(',', map {"$_"} @type_constraints) .']';
+    my $constraint_generator = $self->__infer_constraint_generator;
 
     return $class->new(
         name => $name,
         parent => $self,
         type_constraints => \@type_constraints,
-        constraint_generator => $self->constraint_generator || sub {
+        constraint_generator => $constraint_generator,
+    );
+}
+
+=head2 __infer_constraint_generator
+
+This returns a CODEREF which generates a suitable constraint generator.  Not
+user servicable, you'll never call this directly.
+
+=cut
+
+sub __infer_constraint_generator {
+    my ($self) = @_;
+    if($self->has_constraint_generator) {
+        return $self->constraint_generator;
+    } else {
+        return sub {
+            ## I'm not sure about this stuff but everything seems to work
             my $tc = shift @_;
             my $merged_tc = [@$tc, @{$self->parent->type_constraints}];
-            $self->constraint->($merged_tc, @_);
-        },
-    );
+            $self->constraint->($merged_tc, @_);            
+        };
+    }    
 }
 
 =head2 compile_type_constraint
@@ -132,7 +157,7 @@ around 'create_child_type' => sub {
     my ($create_child_type, $self, %opts) = @_;
     return $self->$create_child_type(
         %opts,
-        constraint_generator => $self->constraint_generator,
+        constraint_generator => $self->__infer_constraint_generator,
     );
 };
 
@@ -191,7 +216,18 @@ sub type_constraints_equals {
 
 =head2 get_message
 
-May want to override this to set a more useful error message
+Give you a better peek into what's causing the error.  For now we stringify the
+incoming deep value with L<Devel::PartialDump> and pass that on to either your
+custom error message or the default one.  In the future we'll try to provide a
+more complete stack trace of the actual offending elements
+
+=cut
+
+around 'get_message' => sub {
+    my ($get_message, $self, $value) = @_;
+    my $new_value = Devel::PartialDump::dump($value);
+    return $self->$get_message($new_value);
+};
 
 =head1 SEE ALSO
 
@@ -210,4 +246,4 @@ it under the same terms as Perl itself.
 
 =cut
 
-1;
\ No newline at end of file
+__PACKAGE__->meta->make_immutable;
\ No newline at end of file