File Coverage

blib/lib/Type/Alias.pm

Criterion	Covered	Total	%
statement	118	122	96.7
branch	26	26	100.0
condition	14	16	87.5
subroutine	31	33	93.9
pod	0	4	0.0
total	189	201	94.0

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

our $VERSION = "0.06";

use feature qw(state);
use Carp qw(croak);
use Scalar::Util qw(blessed);
use Types::Standard qw(Dict Tuple Undef Bool);
use Types::Equal qw( Eq NumEq );

use constant AVAILABLE_BUILTIN => $] >= 5.036;

use constant True => Type::Tiny->new(name => 'True', parent => Bool, constraint => sub { $_ eq !!1 });
use constant False => Type::Tiny->new(name => 'False', parent => Bool, constraint => sub { $_ eq !!0 });

if (AVAILABLE_BUILTIN) {
    eval q!
        use experimental qw(builtin);
        sub is_bool { builtin::is_bool($_[0]) }
        sub created_as_number { builtin::created_as_number($_[0]) }
    !;
}
else {
    eval q!
        sub is_bool { die 'This perl version does not support builtin::is_bool' }
        sub created_as_number { die 'This perl version does not support builtin::created_as_number' }
    !;
}

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)) {
        _to_type_object($v);
    }
    elsif (ref $v) {
        _to_type_reference($v);
    }
    else {
        _to_type_scalar($v);
    }
}

sub _to_type_object {
    my $v = $_[0];

    if ($v->can('check') && $v->can('get_message')) {
        return $v;
    }
    else {
        croak 'This object is not supported: '. ref $v;
    }
}

sub _to_type_reference {
    my $v = $_[0];

    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 ;
    }
}

sub _to_type_scalar {
    my $v = $_[0];

    if (AVAILABLE_BUILTIN) {
        if (!defined $v) {
            return Undef;
        }
        elsif (is_bool($v)) {
            $v ? True : False;
        }
        elsif (created_as_number($v)) {
            NumEq[$v];
        }
        else { # string
            Eq[$v];
        }
    }
    else {
        if (!defined $v) {
            return Undef;
        }
        else { # string, number, bool
            Eq[$v];
        }
    }
}

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__