in reply to Re^2: Near-free function currying in Perl
in thread Near-free function currying in Perl

LOL, you beat me by only a few minutes, I was just going to posts this. 

#!/usr/bin/perl

use strict;
use warnings;

use Test::More tests => 3;

{
    package Test;

    use Attribute::Handlers;

    sub curry : ATTR(CODE) {
        my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
        my @args = split(//, $data);
        my $num_args = scalar(@args);
        my $func = *{$symbol}{NAME};
        no strict 'refs';
        no warnings 'redefine';
        *{"${package}::${func}"} = sub {
                if (scalar(@_) == $num_args) {
                    goto $referent;
                }
                else {
                    my @args = @_;
                    return sub {
                        $referent->(@args, @_);
                    };
                }
            };
    }

    sub foo : curry('$$$') {
        return @_;
    }
    
}
              
is_deeply(
    [ Test::foo(1, 2, 3) ],
    [ 1, 2, 3 ],
    '... got the right return value');   

my $curried_foo = Test::foo(1, 2);              
is(ref($curried_foo), 'CODE', '... this is our curried sub');

is_deeply(
    [ $curried_foo->(3) ],
    [ 1, 2, 3 ],
    '... got the right return value now');

1;

[download]

Although to be honest, neither of our implementations, nor Tom's do what Haskell and Standard ML do, which is too keep currying until all the functions arguments are satisfied. 

my $curried_foo = foo(1);
my $even_more_curried_foo = $curried_foo->(2);
print $even_more_curried_foo->(3); # now we execute the function

[download]
And from my (limited) understanding of prototypes, it seems that this may not be possible since seems it is difficult to assign an attribute to a closure.

-stvn

Replies are listed 'Best First'.
Re^4: Near-free function currying in Perl
by dragonchild (Archbishop) on Nov 17, 2004 at 17:33 UTC
    Easily fixed. 
    package Demo;
require v5.6.1;
use Attribute::Handlers::Prospective;

sub UNIVERSAL::curry : ATTR(CODE,RAWDATA) {
    my ($package, $symbol, $referent, $attr, $data, $phase) = @_;

    my $num = () = $data =~ /(\$)/g;
    my $subname = "$package".'::'.*{$symbol}{NAME};
    *$subname = sub {
        if (@_ < $num) {
            my @x = @_;
            return sub { $subname->(@x, @_ ) };
        }
        $referent->(@_);
    };
}

1;
__END__

    [download]

    Being right, does not endow the right to be rude; politeness costs nothing.
    Being unknowing, is not the same as being stupid.
    Expressing a contrary opinion, whether to the individual or the group, is more often a sign of deeper thought than of cantankerous belligerence.
    Do not mistake your goals as the only goals; your opinion as the only opinion; your confidence as correctness. Saying you know better is not the same as explaining you know better.

[reply]
[d/l]

      Very nice ++

      -stvn
[reply]

In Section Meditations