File Coverage

blib/lib/Sub/Curry.pm

Criterion	Covered	Total	%
statement	111	120	92.5
branch	41	52	78.8
condition	12	20	60.0
subroutine	18	21	85.7
pod	4	8	50.0
total	186	221	84.1

package Sub::Curry;

$VERSION = 0.80;

use 5.006;
use strict;
use base 'Exporter';
use Carp;

BEGIN {
    my @consts = qw/
        ANTISPICE
        HOLE
        ANTIHOLE
        BLACKHOLE
        WHITEHOLE
    /;

    for (@consts) {
        my $val = \(__PACKAGE__ . ".$_");
        no strict 'refs';
        *$_ = sub () { $val };
        *{"is$_"} = sub {
            return @_
                ? ref $_[0] && $_[0] == $val
                : ref $_    && $_    == $val;
        };
    }

    our %EXPORT_TAGS = (
        CONST => [ @consts ],
    );
    our @EXPORT_OK = qw/ curry /;
    push @EXPORT_OK => map @$_ => values %EXPORT_TAGS;
    $EXPORT_TAGS{ALL} = \@EXPORT_OK;
}

sub spice_eq {
    my $x = shift;
    my $y = @_ ? shift : $_;

    return ref $x && ref $y && $x == $y;
}

our (
    $Verbose,
);

# Compability:
sub Hole (;$){
    return map { HOLE() } ( 1 .. ( shift || 1 ) ) if wantarray;
    return HOLE();
}

###############################################################################

BEGIN {
    my %Instance_Data;

    foreach (qw/ uncurried _real_spice _code_str /) {
        no strict 'refs';
        my $prop = $_;
        *$prop = sub {
            my $self = shift;
            if (@_) {
                croak("Don't set '$prop' property outside " . __PACKAGE__)
                    unless caller eq __PACKAGE__;
                return $Instance_Data{$self}->{$prop} = $_[0] if @_;
            }
            return $Instance_Data{$self}->{$prop};
        };
    }

=cut
    foreach ('holes', 'antispices', 'blackholes') {
        no strict 'refs';
        my $prop = $_;
        *$prop = sub {
            my $self = shift;
            if (@_) {
                require Carp;
                Carp::croak("Don't set '$prop' property outside " . __PACKAGE__)
                    unless caller eq __PACKAGE__;
                return @{$Instance_Data{$self}->{$prop} = $_[0]} if @_;
            }
            return @{$Instance_Data{$self}->{$prop}};
        };
    }
=cut

    DESTROY { delete $Instance_Data{+shift} }
}

# Note that the curry sub isn't equivalent to the new method.
# &curry doesn't care if the code ref is an object or not,
# while new does.

sub _alias { \@_ }

sub curry { __PACKAGE__->new(@_) }
sub new {
    if (not ref $_[0]) {
        my $class = shift;

        my $cb = shift;
        my $spice = \@_;

        my @str;
        my $arg_offset = 0;
        my $inc_arg_offset = sub {
            $arg_offset =~ /^\@_/
                ? $arg_offset .= '+1'
                : $arg_offset++;
            return;
        };
        for (my $c = 0; $c < @$spice; $c++) {
            local $_ = $spice->[$c];
            if (! defined $spice->[$c]) {
                push @str => "\$spice->[$c]";
            }
            elsif (spice_eq(HOLE)) {
                push @str => sprintf '$_[%s]', $arg_offset;
                #$arg_offset .= '+1';
                $inc_arg_offset->();
            }
            elsif (spice_eq(ANTISPICE)) {
                $arg_offset .= '+1';
                $inc_arg_offset->();
            }
            elsif (spice_eq(BLACKHOLE)) {
                push @str => sprintf '@_[%s .. $#_]', $arg_offset;
                $arg_offset = '@_';
            }
            else {
                push @str => "\$spice->[$c]";
            }
        }

        #push @str, sprintf '@_[%s .. $#_]', $arg_offset;
        if (1) {
            if ($arg_offset) {
                if ($arg_offset !~ /^\@_/) {
                    push @str, sprintf '@_[%s .. $#_]', $arg_offset;
                }
                # Otherwise you'll get something bigger than @_ in the range,
                # e.g. @_+1 .. $#_ and that will always evaluate to a
                # zero-length slice.
            }
            else {
                # No spice. Just do a regular pass-along.
                push @str, '@_';
            }
        }

        my $code_str = "sub { \$cb->(@{[join ', ', @str]}) }";
        my $self = eval $code_str or die;

        #return $self if $nobless;

        bless $self => $class;

        _code_str($self => $code_str);
        _real_spice($self => $spice);
        $self->uncurried($cb);

        return $self;
    }
    else {
        my $self = shift;

        my $spice = _real_spice($self);

        my $special = grep {
               spice_eq(HOLE)
            or spice_eq(ANTISPICE)
            or spice_eq(BLACKHOLE)
        } @$spice;

        my $new_spice;
        if ($special) {
            my $arg_offset = 0;
            my @str;
            #my $blackhole;
            my $c;
            for ($c = 0; $c < @$spice and $arg_offset < @_; $c++) {
                local $_ = $spice->[$c];
                if (not defined) {
                    push @str => "\$spice->[$c]";
                }
                elsif (spice_eq(ANTISPICE)) {
                    $arg_offset++;
                }
                elsif (spice_eq(HOLE)) {
                    push @str => sprintf '$_[%d]', $arg_offset
                        unless spice_eq(ANTIHOLE, $_[$arg_offset]);
                    $arg_offset++;
                }
                elsif (spice_eq(BLACKHOLE)) {
                    while ($arg_offset < @_ and not spice_eq(WHITEHOLE, $_[$arg_offset])) {
                        push @str => sprintf '$_[%d]', $arg_offset++;
                    }

                    if ($arg_offset < @_) {
                        $arg_offset++; # Skip the whitehole.
                    }
                    else {
                        push @str => "\$spice->[$c]"; # Keep the blackhole.
                    }
                }
                else {
                    push @str => "\$spice->[$c]";
                }
            }

            if ($c < @$spice) {
                push @str => map "\$spice->[$_]" => $c .. $#$spice;
            }
            else {
                push @str, sprintf '@_[%d .. $#_]', $arg_offset;
            }

            $new_spice = eval "_alias(@{[join ', ', @str]})" or die;
        }
        else {
            $new_spice = _alias(@$spice, @_);
        }

        return ref($self)->new($self->uncurried, @$new_spice);
    }
}

sub clone { $_[0]->new }

sub call { goto &{$_[0]} }

sub spice { @{_real_spice($_[0])} }

sub cursed {
    my $self = shift;

    my $cb = $self->uncurried;
    my $spice = _real_spice($self);
    my $cursed = eval _code_str($self);
    die "Internal error: $@" if $@;

    return $cursed;
}

__PACKAGE__;

__END__