lib/MooseX/Meta/TypeConstraint/Structured.pm

   1 package ## Hide from PAUSE
   2  MooseX::Meta::TypeConstraint::Structured;
   3 # ABSTRACT: Structured type constraints.
   4
   5 use Moose;
   6 use Devel::PartialDump;
   7 use Moose::Util::TypeConstraints ();
   8 use MooseX::Meta::TypeCoercion::Structured;
   9 extends 'Moose::Meta::TypeConstraint';
  10
  11
  12 =head1 DESCRIPTION
  13
  14 A structure is a set of L<Moose::Meta::TypeConstraint> that are 'aggregated' in
  15 such a way as that they are all applied to an incoming list of arguments.  The
  16 idea here is that a Type Constraint could be something like, "An C<Int> followed by
  17 an C<Int> and then a C<Str>" and that this could be done so with a declaration like:
  18
  19     Tuple[Int,Int,Str]; ## Example syntax
  20
  21 So a structure is a list of type constraints (the C<Int,Int,Str> in the above
  22 example) which are intended to function together.
  23
  24 =attr type_constraints
  25
  26 A list of L<Moose::Meta::TypeConstraint> objects.
  27
  28 =cut
  29
  30 has 'type_constraints' => (
  31     is=>'ro',
  32     isa=>'Ref',
  33     predicate=>'has_type_constraints',
  34 );
  35
  36 =attr constraint_generator
  37
  38 =for stopwords subref
  39
  40 A subref or closure that contains the way we validate incoming values against
  41 a set of type constraints.
  42
  43 =cut
  44
  45 has 'constraint_generator' => (
  46     is=>'ro',
  47     isa=>'CodeRef',
  48     predicate=>'has_constraint_generator',
  49 );
  50
  51 has coercion => (
  52     is      => 'ro',
  53     isa     => 'Object',
  54     builder => '_build_coercion',
  55 );
  56
  57 sub _build_coercion {
  58     my ($self) = @_;
  59     return MooseX::Meta::TypeCoercion::Structured->new(
  60         type_constraint => $self,
  61     );
  62 }
  63
  64 =method validate
  65
  66 Messing with validate so that we can support nicer error messages.
  67
  68 =cut
  69
  70 sub _clean_message {
  71     my $message = shift @_;
  72     $message =~s/MooseX::Types::Structured:://g;
  73     return $message;
  74 }
  75
  76 override 'validate' => sub {
  77     my ($self, $value, $message_stack) = @_;
  78     unless ($message_stack) {
  79         $message_stack = MooseX::Types::Structured::MessageStack->new();
  80     }
  81
  82     $message_stack->inc_level;
  83
  84     if ($self->_compiled_type_constraint->($value, $message_stack)) {
  85         ## Everything is good, no error message to return
  86         return undef;
  87     } else {
  88         ## Whoops, need to figure out the right error message
  89         my $args = Devel::PartialDump::dump($value);
  90         $message_stack->dec_level;
  91         if($message_stack->has_messages) {
  92             if($message_stack->level) {
  93                 ## we are inside a deeply structured constraint
  94                 return $self->get_message($args);
  95             } else {
  96                 my $message_str = $message_stack->as_string;
  97                 return _clean_message($self->get_message("$args, Internal Validation Error is: $message_str"));
  98             }
  99         } else {
 100             return $self->get_message($args);
 101         }
 102     }
 103 };
 104
 105 =method generate_constraint_for ($type_constraints)
 106
 107 Given some type constraints, use them to generate validation rules for an ref
 108 of values (to be passed at check time)
 109
 110 =cut
 111
 112 sub generate_constraint_for {
 113     my ($self, $type_constraints) = @_;
 114     return $self->constraint_generator->($self, $type_constraints);
 115 }
 116
 117 =for stopwords parameterize
 118
 119 =method parameterize (@type_constraints)
 120
 121 Given a ref of type constraints, create a structured type.
 122
 123 =cut
 124
 125 sub parameterize {
 126     my ($self, @type_constraints) = @_;
 127     my $class = ref $self;
 128     my $name = $self->name .'['. join(',', map {"$_"} @type_constraints) .']';
 129     my $constraint_generator = $self->__infer_constraint_generator;
 130
 131     return $class->new(
 132         name => $name,
 133         parent => $self,
 134         type_constraints => \@type_constraints,
 135         constraint_generator => $constraint_generator,
 136     );
 137 }
 138
 139 =method __infer_constraint_generator
 140
 141 =for stopwords servicable
 142
 143 This returns a CODEREF which generates a suitable constraint generator.  Not
 144 user servicable, you'll never call this directly.
 145
 146 =cut
 147
 148 sub __infer_constraint_generator {
 149     my ($self) = @_;
 150     if($self->has_constraint_generator) {
 151         return $self->constraint_generator;
 152     } else {
 153         return sub {
 154             ## I'm not sure about this stuff but everything seems to work
 155             my $tc = shift @_;
 156             my $merged_tc = [@$tc, @{$self->parent->type_constraints}];
 157             $self->constraint->($merged_tc, @_);
 158         };
 159     }
 160 }
 161
 162 =method compile_type_constraint
 163
 164 hook into compile_type_constraint so we can set the correct validation rules.
 165
 166 =cut
 167
 168 around 'compile_type_constraint' => sub {
 169     my ($compile_type_constraint, $self, @args) = @_;
 170
 171     if($self->has_type_constraints) {
 172         my $type_constraints = $self->type_constraints;
 173         my $constraint = $self->generate_constraint_for($type_constraints);
 174         $self->_set_constraint($constraint);
 175     }
 176
 177     return $self->$compile_type_constraint(@args);
 178 };
 179
 180 =method create_child_type
 181
 182 modifier to make sure we get the constraint_generator
 183
 184 =cut
 185
 186 around 'create_child_type' => sub {
 187     my ($create_child_type, $self, %opts) = @_;
 188     return $self->$create_child_type(
 189         %opts,
 190         constraint_generator => $self->__infer_constraint_generator,
 191     );
 192 };
 193
 194 =method is_a_type_of
 195
 196 =method is_subtype_of
 197
 198 =method equals
 199
 200 Override the base class behavior.
 201
 202 =cut
 203
 204 sub equals {
 205     my ( $self, $type_or_name ) = @_;
 206     my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name)
 207       or return;
 208
 209     return unless $other->isa(__PACKAGE__);
 210
 211     return (
 212         $self->parent->equals($other->parent)
 213             and
 214         $self->type_constraints_equals($other)
 215     );
 216 }
 217
 218 sub is_a_type_of {
 219     my ( $self, $type_or_name ) = @_;
 220     my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name)
 221       or return;
 222
 223     if ( $other->isa(__PACKAGE__) and @{ $other->type_constraints || [] }) {
 224         if ( $self->parent->is_a_type_of($other->parent) ) {
 225             return $self->_type_constraints_op_all($other, "is_a_type_of");
 226         } elsif ( $self->parent->is_a_type_of($other) ) {
 227             return 1;
 228             # FIXME compare?
 229         } else {
 230             return 0;
 231         }
 232     } else {
 233         return $self->SUPER::is_a_type_of($other);
 234     }
 235 }
 236
 237 sub is_subtype_of {
 238     my ( $self, $type_or_name ) = @_;
 239     my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name)
 240       or return;
 241     if ( $other->isa(__PACKAGE__) ) {
 242         if ( $other->type_constraints and $self->type_constraints ) {
 243             if ( $self->parent->is_a_type_of($other->parent) ) {
 244                 return (
 245                     $self->_type_constraints_op_all($other, "is_a_type_of")
 246                       and
 247                     $self->_type_constraints_op_any($other, "is_subtype_of")
 248                 );
 249             } elsif ( $self->parent->is_a_type_of($other) ) {
 250                 return 1;
 251                 # FIXME compare?
 252             } else {
 253                 return 0;
 254             }
 255         } else {
 256             if ( $self->type_constraints ) {
 257                 if ( $self->SUPER::is_subtype_of($other) ) {
 258                     return 1;
 259                 } else {
 260                     return;
 261                 }
 262             } else {
 263                 return $self->parent->is_subtype_of($other->parent);
 264             }
 265         }
 266     } else {
 267         return $self->SUPER::is_subtype_of($other);
 268     }
 269 }
 270
 271 =method type_constraints_equals
 272
 273 Checks to see if the internal type constraints are equal.
 274
 275 =cut
 276
 277 sub type_constraints_equals {
 278     my ( $self, $other ) = @_;
 279     $self->_type_constraints_op_all($other, "equals");
 280 }
 281
 282 sub _type_constraints_op_all {
 283     my ($self, $other, $op) = @_;
 284
 285     return unless $other->isa(__PACKAGE__);
 286
 287     my @self_type_constraints = @{$self->type_constraints||[]};
 288     my @other_type_constraints = @{$other->type_constraints||[]};
 289
 290     return unless @self_type_constraints == @other_type_constraints;
 291
 292     ## Incoming ay be either arrayref or hashref, need top compare both
 293     while(@self_type_constraints) {
 294         my $self_type_constraint = shift @self_type_constraints;
 295         my $other_type_constraint = shift @other_type_constraints;
 296
 297         $_ = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($_)
 298           for $self_type_constraint, $other_type_constraint;
 299
 300         my $result = $self_type_constraint->$op($other_type_constraint);
 301         return unless $result;
 302     }
 303
 304     return 1; ##If we get this far, everything is good.
 305 }
 306
 307 sub _type_constraints_op_any {
 308     my ($self, $other, $op) = @_;
 309
 310     return unless $other->isa(__PACKAGE__);
 311
 312     my @self_type_constraints = @{$self->type_constraints||[]};
 313     my @other_type_constraints = @{$other->type_constraints||[]};
 314
 315     return unless @self_type_constraints == @other_type_constraints;
 316
 317     ## Incoming ay be either arrayref or hashref, need top compare both
 318     while(@self_type_constraints) {
 319         my $self_type_constraint = shift @self_type_constraints;
 320         my $other_type_constraint = shift @other_type_constraints;
 321
 322         $_ = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($_)
 323           for $self_type_constraint, $other_type_constraint;
 324
 325         return 1 if $self_type_constraint->$op($other_type_constraint);
 326     }
 327
 328     return 0;
 329 }
 330
 331 =method get_message
 332
 333 Give you a better peek into what's causing the error.  For now we stringify the
 334 incoming deep value with L<Devel::PartialDump> and pass that on to either your
 335 custom error message or the default one.  In the future we'll try to provide a
 336 more complete stack trace of the actual offending elements
 337
 338 =cut
 339
 340 around 'get_message' => sub {
 341     my ($get_message, $self, $value) = @_;
 342     $value = Devel::PartialDump::dump($value)
 343      if ref $value;
 344     return $self->$get_message($value);
 345 };
 346
 347 =head1 SEE ALSO
 348
 349 The following modules or resources may be of interest.
 350
 351 L<Moose>, L<Moose::Meta::TypeConstraint>
 352
 353 =cut
 354
 355 __PACKAGE__->meta->make_immutable(inline_constructor => 0);