File Coverage

blib/lib/Sub/Curried.pm

Criterion	Covered	Total	%
statement	44	48	91.6
branch	18	20	90.0
condition			n/a
subroutine	12	13	92.3
pod	0	3	0.0
total	74	84	88.1

=head1 NAME

Sub::Curried - automatically curried subroutines

=head1 SYNOPSIS

 curry add_n_to ($n, $val) {
    return $n+$val;
 }

 my $add_10_to = add_n_to( 10 );

 say $add_10_to->(4);  # 14

 # but you can also
 say add_n_to(10,4);  # also 14

 # or more traditionally
 say add_n_to(10)->(4);

=head1 DESCRIPTION

Currying and Partial Application come from the heady world of functional
programming, but are actually useful techniques.  Partial Application is used
to progressively specialise a subroutine, by pre-binding some of the arguments.

Partial application is the generic term, that also encompasses the concept of
plugging in "holes" in arguments at arbitrary positions.  Currying is more
specifically the application of arguments progressively from left to right
until you have enough of them.

=head1 DEPENDENCIES

Beyond those listed in META.yml/META.json, there is an optional dependency on
PPR: if you have it installed, then your curry definitions can include POD
syntax anywhere whitespace can occur between C and C<{>.  Without PPR,
that will trigger a syntax error.

If your Perl is older than 5.16, you'll also need Sub::Current.

=head1 USAGE

Define a curried subroutine using the C keyword.  You should list the
arguments to the subroutine in parentheses.  This isn't a sophisticated signature
parser, just a common separated list of scalars (or C<@array> or C<%hash> arguments,
which will be returned as a I).

    curry greet ($greeting, $greetee) {
        return "$greeting $greetee";
    }

    my $hello = greet("Hello");
    say $hello->("World"); # Hello World

=head2 Currying

Currying applies the arguments from left to right, returning a more specialised function
as it goes until all the arguments are ready, at which point the sub returns its value.

    curry three ($one,$two,$three) {
        return $one + $two * $three
    }

    three(1,2,3)  # normal call - returns 7

    three(1)      # a new subroutine, with $one bound to the number 1
        ->(2,3)   # call the new sub with these arguments

    three(1)->(2)->(3) # You could call the curried sub like this,
                       # instead of commas (1,2,3)

What about calling with I arguments?  By extension that would return a function exactly
like the original one... but with I arguments prebound (i.e. it's an alias!)

    my $fn = three;   # same as my $fn = \&three;

=head2 Anonymous curries

Just like you can have anonymous subs, you can have anonymous curried subs:

    my $greet = curry ($greeting, $greetee) { ... }

=head2 Composition

Curried subroutines are I.  This means that we can create a new
subroutine that takes the result of the second subroutine as the input of the
first.

Let's say we wanted to expand our greeting to add some punctuation at the end:

    curry append  ($r, $l) { $l . $r }
    curry prepend ($l, $r) { $l . $r }

    my $ciao = append('!') << prepend('Ciao ');
    say $ciao->('Bella'); # Ciao Bella!

How does this work?  Follow the pipeline in the direction of the EE...
First we prepend 'Ciao ' to get 'Ciao Bella', then we pass that to the curry that
appends '!'.  We can also write them in the opposite order, to match evaluation
order, by reversing the operator:

    my $ciao = prepend('Ciao ') >> append('!');
    say $ciao->('Bella'); # Ciao Bella!

Finally, we can create a shell-like pipeline:

    say 'Bella' | prepend('Ciao ') | append('!'); # Ciao Bella!

The overloaded syntax is provided by C which is distributed with
this module as a base class.

=head2 Argument aliasing

When all the arguments are supplied and the function body is executed, the
arguments values are available in both the named parameters and the C<@_>
array.  Just as in a normal subroutine call, the elements of C<@_> (but
I the named parameters) are aliased to the variables supplied by the
caller, so you can use pass-by-reference semantics.

    curry set ($a, $b) {
      foreach my $arg (@_) { $arg = 1; } # affects the caller
      $a = $b = 2;                       # doesn't affect the caller
    }
    my ($x, $y) = (0, 0);
    set($x)->($y); # $x == 1, $y == 1

=head2 Stack traces

The innermost stack frame has the function name you defined, with all the
accumulated arguments.  Any intermediate stack frames have the same or
similar function names; currently there is a C<__curried> suffix, but that
may change in the future.  Currently there is only one intermediate stack
frame, showing just the arguments that were passed in the final call that
reached the required number of arguments, but that may change in the future.
If you supply all the arguments in one call, there are no intermediate stack
frames.

    use Carp 'confess';
    curry func ($a, $b, $c, $d) {
      confess('ERROR MESSAGE');
    }
    sub call {
      func(1)->(2)->(3, 4);
    }
    call();

    ERROR MESSAGE at script.pl line 3
           main::func(1, 2, 3, 4) called at .../Sub/Curried.pm line 202
           main::func__curried(3, 4) called at script.pl line 6
           main::call() called at script.pl line 8

=cut

use strict; use warnings;
package Sub::Curried;
$Sub::Curried::VERSION = '0.14';
use parent 'Sub::Composable';

use Sub::Name;
use Keyword::Pluggable 1.05;
use Attribute::Handlers;

sub import {
    Keyword::Pluggable::define('keyword'    => 'curry',
                               'code'       => \&injector,
                               'expression' => 'dynamic');
}

sub unimport {
    Keyword::Pluggable::undefine('keyword' => 'curry');
}

sub UNIVERSAL::Sub__Curried :ATTR(CODE) {
    my ($package, $symbol, $ref, $attr, $arg) = @_;
    bless($ref, __PACKAGE__);
}

my $current_sub;
BEGIN {
    if ($^V lt v5.16.0) {
        require Sub::Current;
        $current_sub = 'Sub::Current::ROUTINE';
    } else {
        $current_sub = 'CORE::__SUB__';
    }
}

# PPR is the easiest way to parse POD.  But POD between "curry" and "{" was
# never supported before, and PPR may be slow depending on the Perl version,
# so make it optional.
eval { require PPR; };
my $space  = qr/(?:\s|#[^\n]*\n)/;
my $ppr    = exists($INC{"PPR/pm"})? $PPR::GRAMMAR: '';
my $nspace = exists($INC{"PPR/pm"})? '(?&PerlNWS)': qr/$space+/;
my $ospace = exists($INC{"PPR/pm"})? '(?&PerlOWS)': qr/$space*/;
my $sigil  = qr/[\$\%\@]/;
my $ident  = qr/(?:\p{XIDS}\p{XIDC}*)/;
my $param  = qr/$ospace $sigil $ident/x;

sub injector {
    my ($text) = @_;
    if ($$text !~ s/\A
                    (? $nspace (?$ident))?
                    (? $ospace \(
                      (? $param (?: $ospace , $param)* )?
                      $ospace \) )?
                    (? $ospace ) \{ $ppr
                   /injection(%+)/xe) {
        die('invalid Sub::Curried syntax: '.substr($$text, 0, 80).'...');
    }
    return !defined($+{'name'});
}

sub injection {
    my (%match) = @_;
    my $esc_name = $match{'name'};
    if (defined($esc_name)) { $esc_name =~ s/([\\'])/\\$1/g; }
    my $curried_name = (defined($match{'name'})
                        ? $match{'name'} . '__curried'
                        : undef);
    my $esc_curried_name = $curried_name;
    if (defined($esc_curried_name)) { $esc_curried_name =~ s/([\\'])/\\$1/g; }
    my @name_wrapper = (defined($curried_name)
                        ? ("Sub::Name::subname('".$esc_curried_name."', ", ")")
                        : ('', ''));
    my @params = (defined($match{'params'})
                  ? @{[ ($match{'params'}.',') =~
                        m/$ospace ($sigil $ident) $ospace,$ppr/gx ]}
                  : ());
    return join('',
                'sub', grep(defined($_), $match{'spacename'}),
                ' :Sub__Curried', $match{'space'}, '{',
                ' if (@_ > ', scalar(@params), ') {',
                  " die('", (defined($esc_name)
                            ? $esc_name
                            : ''),
                       ", expected ", scalar(@params),
                       " args but got '.\@_);",
                ' }',
                (@params == 0
                 ? () # We never need to return a closure
                 : (
                 ' if (@_ < ', scalar(@params), ') {',
                   ' my $func = ', $current_sub, ';',
                   ' my $args = \@_;',
                   ' return ',
                      $name_wrapper[0],
                      'bless(sub { $func->(@$args, @_) }, "Sub::Curried")',
                      $name_wrapper[1],
                    ';',
                 ' }')),
                map({ my @param = ('$_[', $_, ']');
                      (' my ', $params[$_], ' = ',
                       ($params[$_]=~/^([\%\@])/
                        ? ($1, '{', @param, '}')
                        : @param), ';') }
                    0..$#params));
}

=head1 BUGS

No major bugs currently open.  Please report any bugs via RT or email.

=head1 SEE ALSO

L provides the syntactic magic.

There are several modules on CPAN that already do currying or partial evaluation:

=over 4

=item *

L - Filter based module prototyping the Perl 6 system

=item *

L - seems rather complex, with concepts like blackholes and antispices.  Odd.

=item *

L - creates a currying variant of all existing subs automatically.  Very odd.

=item *

L - partial evaluation with named arguments (as hash keys).  Has some
great debugging hooks (the function is a blessed object which displays what the current
bound keys are).

=item *

L - exactly what we want minus the sugar.  (The attribute has
to declare how many arguments it's expecting)

=back

=head1 AUTHOR

 (c)2008-2013 [e-mail]
 (c)2024 Paul Jarc

=head1 CONTRIBUTORS

=over 4

=item *

Florian (rafl) Ragwitz

=back

=head1 LICENSE

This module is distributed under the same terms and conditions as Perl itself.

=head1 CONTRIBUTING

Please submit bugs to RT or email.

A git repo is available at L

=cut

1;