package Fun;
use strict;
use warnings;
use Parse::Keyword { fun => \&fun_parser };
use Sub::Name 'subname';
use Exporter 'import';
our @EXPORT = 'fun';
# XXX this isn't quite right, i think, but probably close enough for now?
my $start_rx = qr/^[\p{ID_Start}_]$/;
my $cont_rx = qr/^\p{ID_Continue}$/;
sub fun { @_ ? $_[0] : () }
sub fun_parser {
my ($name, $prototype, $body);
lex_read_space;
if (lex_peek =~ /$start_rx|^:$/) {
$name = parse_name(1);
}
lex_read_space;
if (lex_peek eq '(') {
$prototype = parse_prototype();
}
lex_read_space;
if (lex_peek eq '{') {
local $Fun::{'DEFAULTS::'};
if ($prototype) {
lex_read;
my $preamble = '{';
my @names = map { $_->{name} } @$prototype;
$preamble .= 'my (' . join(', ', @names) . ') = @_;';
my $index = 1;
for my $var (grep { defined $_->{default} } @$prototype) {
{
no strict 'refs';
*{ 'Fun::DEFAULTS::default_' . $index } = sub () {
$var->{default}
};
}
$preamble .= $var->{name} . ' = Fun::DEFAULTS::default_' . $index . '->()' . ' unless @_ > ' . $var->{index} . ';';
$index++;
}
lex_stuff($preamble);
}
$body = parse_block;
}
else {
die "syntax error";
}
if (defined $name) {
my $full_name = join('::', compiling_package, $name);
{
no strict 'refs';
*$full_name = subname $full_name, $body;
}
return (sub {}, 1);
}
else {
return (sub { $body }, 0);
}
}
sub parse_name {
my ($allow_package) = @_;
my $name = '';
my $char_rx = $start_rx;
while (1) {
my $char = lex_peek;
last unless length $char;
if ($char =~ $char_rx) {
$name .= $char;
lex_read;
$char_rx = $cont_rx;
}
elsif ($allow_package && $char eq ':') {
die "syntax error" unless lex_peek(3) =~ /^::(?:[^:]|$)/;
$name .= '::';
lex_read(2);
}
else {
last;
}
}
return length($name) ? $name : undef;
}
sub parse_prototype {
die "syntax error" unless lex_peek eq '(';
lex_read;
lex_read_space;
if (lex_peek eq ')') {
lex_read;
return;
}
my $seen_slurpy;
my @vars;
while ((my $sigil = lex_peek) ne ')') {
my $var = {};
die "syntax error"
unless $sigil eq '$' || $sigil eq '@' || $sigil eq '%';
die "Can't declare parameters after a slurpy parameter"
if $seen_slurpy;
$seen_slurpy = 1 if $sigil eq '@' || $sigil eq '%';
lex_read;
lex_read_space;
my $name = parse_name(0);
lex_read_space;
$var->{name} = "$sigil$name";
if (lex_peek eq '=') {
lex_read;
lex_read_space;
$var->{default} = parse_arithexpr;
}
$var->{index} = @vars;
push @vars, $var;
die "syntax error"
unless lex_peek eq ')' || lex_peek eq ',';
if (lex_peek eq ',') {
lex_read;
lex_read_space;
}
}
lex_read;
return \@vars;
}
1;