lib/Moose/Meta/TypeConstraint/Parameterizable.pm

   1 package Moose::Meta::TypeConstraint::Parameterizable;
   2
   3 use strict;
   4 use warnings;
   5 use metaclass;
   6
   7 our $VERSION   = '0.57';
   8 $VERSION = eval $VERSION;
   9 our $AUTHORITY = 'cpan:STEVAN';
  10
  11 use base 'Moose::Meta::TypeConstraint';
  12 use Moose::Meta::TypeConstraint::Parameterized;
  13
  14 __PACKAGE__->meta->add_attribute('constraint_generator' => (
  15     accessor  => 'constraint_generator',
  16     predicate => 'has_constraint_generator',
  17 ));
  18
  19 sub generate_constraint_for {
  20     my ($self, $type) = @_;
  21
  22     return unless $self->has_constraint_generator;
  23
  24     return $self->constraint_generator->($type->type_parameter)
  25         if $type->is_subtype_of($self->name);
  26
  27     return $self->_can_coerce_constraint_from($type)
  28         if $self->has_coercion
  29         && $self->coercion->has_coercion_for_type($type->parent->name);
  30
  31     return;
  32 }
  33
  34 sub _can_coerce_constraint_from {
  35     my ($self, $type) = @_;
  36     my $coercion   = $self->coercion;
  37     my $constraint = $self->constraint_generator->($type->type_parameter);
  38     return sub {
  39         local $_ = $coercion->coerce($_);
  40         $constraint->(@_);
  41     };
  42 }
  43
  44 sub parameterize {
  45         my ($self, @args) = @_;
  46
  47     ## ugly hacking to deal with tc naming normalization issue
  48     my ($tc_name, $contained_tc);
  49     if (ref $args[0]) {
  50         $contained_tc = shift @args;
  51         $tc_name = $self->name .'['. $contained_tc->name .']';
  52     } else {
  53         ($tc_name, $contained_tc) = @args;
  54     }
  55
  56         unless($contained_tc->isa('Moose::Meta::TypeConstraint')) {
  57                 Moose->throw_error("The type parameter must be a Moose meta type");
  58         }
  59
  60     return Moose::Meta::TypeConstraint::Parameterized->new(
  61         name           => $tc_name,
  62         parent         => $self,
  63         type_parameter => $contained_tc,
  64     );
  65 }
  66
  67
  68 1;
  69
  70 __END__
  71
  72
  73 =pod
  74
  75 =head1 NAME
  76
  77 Moose::Meta::TypeConstraint::Parameterizable - Higher Order type constraints for Moose
  78
  79 =head1 METHODS
  80
  81 =over 4
  82
  83 =item B<constraint_generator>
  84
  85 =item B<has_constraint_generator>
  86
  87 =item B<generate_constraint_for>
  88
  89 =item B<parameterize>
  90
  91 Given an array of type constraints, parameterize the current type constraint.
  92
  93 =item B<meta>
  94
  95 =back
  96
  97 =head1 BUGS
  98
  99 All complex software has bugs lurking in it, and this module is no
 100 exception. If you find a bug please either email me, or add the bug
 101 to cpan-RT.
 102
 103 =head1 AUTHOR
 104
 105 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 106
 107 =head1 COPYRIGHT AND LICENSE
 108
 109 Copyright 2006-2008 by Infinity Interactive, Inc.
 110
 111 L<http://www.iinteractive.com>
 112
 113 This library is free software; you can redistribute it and/or modify
 114 it under the same terms as Perl itself.
 115
 116 =cut