File Coverage

blib/lib/Type/Alias.pm

Criterion	Covered	Total	%
statement	97	97	100.0
branch	26	26	100.0
condition	13	16	81.2
subroutine	24	24	100.0
pod	0	2	0.0
total	160	165	96.9

package Type::Alias;
use strict;
use warnings;

our $VERSION = "0.05";

use feature qw(state);
use Carp qw(croak);
use Scalar::Util qw(blessed);
use Types::Standard qw(Dict Tuple);

sub import {
    my ($class, %args) = @_;

    my $target_package = caller;

    $class->_define_type($target_package, $args{type});
    $class->_predefine_type_aliases($target_package, $args{'-alias'});
    $class->_predefine_type_functions($target_package, $args{'-fun'});
}

sub _define_type {
    my ($class, $target_package, $options) = @_;
    $options //= {};
    my $type_name = $options->{'-as'} // 'type';

    if ($target_package->can($type_name)) {
        croak "Alreay exists function '${target_package}::${type_name}'. Can specify another name: type => { -as => 'XXX' }.";
    }

    no strict qw(refs);
    no warnings qw(once);
    *{"${target_package}::${type_name}"} = sub {
        my ($alias_name, $type_args) = @_;

        no strict qw(refs);
        no warnings qw(redefine); # Already define empty type alias at _import_type_aliases
        *{"${target_package}::${alias_name}"} = generate_type_alias($type_args);
    }
}

sub _predefine_type_aliases {
    my ($class, $target_package, $type_aliases) = @_;
    $type_aliases //= [];

    for my $alias_name (@$type_aliases) {
        if ($target_package->can($alias_name)) {
            croak "Cannot predeclare type alias '${target_package}::${alias_name}'.";
        }

        no strict qw(refs);
        *{"${target_package}::${alias_name}"} = sub :prototype() {
            croak "You should define type alias '$alias_name' before using it."
        }
    }
}

sub _predefine_type_functions {
    my ($class, $target_package, $type_functions) = @_;
    $type_functions //= [];

    for my $type_function (@$type_functions) {
        if ($target_package->can($type_function)) {
            croak "Cannot predeclare type function '${target_package}::${type_function}'.";
        }

        no strict qw(refs);
        *{"${target_package}::${type_function}"} = sub :prototype(;$) {
            croak "You should define type function '$type_function' before using it."
        }
    }
}

sub to_type {
    my $v = shift;
    if (blessed($v)) {
        if ($v->can('check') && $v->can('get_message')) {
            return $v;
        }
        else {
            croak 'This object is not supported: '. ref $v;
        }
    }
    elsif (ref $v) {
        if (ref $v eq 'ARRAY') {
            return Tuple[ map { to_type($_) } @$v ];
        }
        elsif (ref $v eq 'HASH') {
            return Dict[
                map { $_ => to_type($v->{$_}) } sort { $a cmp $b } keys %$v
            ];
        }
        elsif (ref $v eq 'CODE') {
            return sub {
                my @args;
                if (@_) {
                    unless (@_ == 1 && ref $_[0] eq 'ARRAY') {
                        croak 'This type requires an array reference';
                    }
                    @args = map { to_type($_) } @{$_[0]};
                }

                to_type($v->(@args));
            }
        }
        else {
            croak 'This reference is not supported: ' . ref $v ;
        }
    }
    else {
        # TODO: Is it better to make it a type that checks whether it matches the given value?
        croak 'This value is not supported: ' . (defined $v ? $v : 'undef');
    }
}

sub generate_type_alias {
    my ($type_args) = @_;

    if ( (ref $type_args||'') eq 'CODE') {
        return sub :prototype(;$) {
            state $type = to_type($type_args);
            $type->(@_);
        };
    }
    else {
        return sub :prototype() {
            state $type = to_type($type_args);
            $type;
        }
    }
}

1;
__END__