fixed typo

[catagits/CatalystX-Declare.git] / lib / CatalystX / Declare / Controller / Meta / TypeConstraintMapping.pm

use MooseX::Declare;

role CatalystX::Declare::Controller::Meta::TypeConstraintMapping {

    use MooseX::Types::Moose qw( HashRef Object ArrayRef Str CodeRef );

    use aliased 'Moose::Meta::TypeConstraint';
    use aliased 'MooseX::Method::Signatures::Meta::Method', 'MethodWithSignature';

    has method_type_constraint_map => (
        traits    => [ 'Hash' ],
        is          => 'ro',
        isa         => HashRef[Object],
        required    => 1,
        lazy_build  => 1,
        handles    => {
            'get_method_type_constraint' => 'get',
            'set_method_type_constraint' => 'set',
        },
    );

    has method_named_param_map => (
        traits    => [ 'Hash' ],
        is          => 'ro',
        isa         => HashRef[ArrayRef[Str]],
        required    => 1,
        lazy_build  => 1,
        handles    => {
            'get_method_named_params' => 'get',
            'set_method_named_params' => 'set',
        },
    );

    has method_named_type_constraint_map => (
        traits    => [ 'Hash' ],
        is          => 'ro',
        isa         => HashRef[HashRef[Object]],
        required    => 1,
        lazy_build  => 1,
        handles    => {
            'get_method_named_type_constraint' => 'get',
            'set_method_named_type_constraint' => 'set',
        },
    );

    method _build_method_type_constraint_map {
        return +{};
    }

    method _build_method_named_type_constraint_map {
        return +{};
    }

    method _build_method_named_param_map {
        return +{};
    }

    around add_method ($method_name, $method) {

        if (is_Object $method and $method->isa(MethodWithSignature)) {

            my $tc = $method->type_constraint;

            $self->set_method_type_constraint(
                $method_name,
                $tc,
            );

            if ($method->parsed_signature->has_named_params) {
                my $named = $method->parsed_signature->named_params;

                $self->set_method_named_params(
                    $method_name,
                    [ map $_->label, @$named ],
                );
                $self->set_method_named_type_constraint(
                    $method_name,
                    { map +($_->label, $_->meta_type_constraint), @$named },
                );
            }
        }

        return $self->$orig($method_name, $method);
    }

    method _find_capable_classes (CodeRef $test) {

        return
            grep { local $_ = $_; $_->$test }
            $self,
            map  { $_->meta }
            grep { $_->can('meta') }
                 $self->linearized_isa;
    }

    method find_method_named_params (Str $name) {

        my @parents = $self->_find_capable_classes(sub { $_->can('get_method_named_params') });

        for my $isa (@parents) {

            if (my $named = $isa->get_method_named_params($name)) {
                return [@$named];
            }
        }

        return undef;
    }

    method find_method_named_type_constraint (Str $method, Str $param) {

        my @parents = $self->_find_capable_classes(sub { $_->can('get_method_named_type_constraint') });

        for my $isa (@parents) {

            if (my $named = $isa->get_method_named_type_constraint($method)) {
                return $named->{ $param };
            }
        }

        return undef;
    }

    method find_method_type_constraint (Str $name) {

        my @parents = $self->_find_capable_classes(sub { $_->can('get_method_type_constraint') });

        for my $isa (@parents) {
            
            if (my $tc = $isa->get_method_type_constraint($name)) {
                return $tc;
            }
        }

        return undef;
    }
}