add tests for Fun

13 files changed, 469 insertions, 1 deletions

diff --git a/dist.ini b/dist.ini
index adf1cce..0e9bb8b 100644
--- a/dist.ini
+++ b/dist.ini
@@ -13,7 +13,7 @@ awesome = =inc::MakeMaker
 
 [AutoPrereqs]
 skip = ^Error.*$
-skip = ^Try$
+skip = ^(?:Try|Fun)$
 [Prereqs / ConfigureRequires]
 Devel::CallParser = 0
 
diff --git a/t/fun/anon.t b/t/fun/anon.t
new file mode 100644
index 0000000..88b6991
--- /dev/null
+++ b/t/fun/anon.t
@@ -0,0 +1,17 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use lib 't/fun/lib';
+
+use Fun;
+
+my $fun = fun ($x, $y) { $x * $y };
+
+is($fun->(3, 4), 12);
+
+my $fun2 = fun ($z, $w = 10) { $z / $w };
+
+is($fun2->(60), 6);
+
+done_testing;
diff --git a/t/fun/basic.t b/t/fun/basic.t
new file mode 100644
index 0000000..53a8476
--- /dev/null
+++ b/t/fun/basic.t
@@ -0,0 +1,34 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use lib 't/fun/lib';
+
+use Fun;
+
+fun mul ($x, $y) {
+    return $x * $y;
+}
+
+is(mul(3, 4), 12);
+
+fun sum (@nums) {
+    my $sum;
+    for my $num (@nums) {
+        $sum += $num;
+    }
+    return $sum;
+}
+
+is(sum(1, 2, 3, 4), 10);
+
+{
+    package Foo;
+    use Fun;
+    fun foo { }
+    foo();
+}
+
+ok(exists $Foo::{foo});
+
+done_testing;
diff --git a/t/fun/closure-proto.t b/t/fun/closure-proto.t
new file mode 100644
index 0000000..bc9ede5
--- /dev/null
+++ b/t/fun/closure-proto.t
@@ -0,0 +1,20 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use Test::More;
+use lib 't/fun/lib';
+
+use Fun;
+
+{
+    my $x = 10;
+
+    fun bar ($y) {
+        $x * $y
+    }
+}
+
+is(bar(3), 30);
+
+done_testing;
diff --git a/t/fun/compile-time.t b/t/fun/compile-time.t
new file mode 100644
index 0000000..cc72455
--- /dev/null
+++ b/t/fun/compile-time.t
@@ -0,0 +1,13 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use lib 't/fun/lib';
+
+use Fun;
+
+is(foo(), "FOO");
+
+fun foo { "FOO" }
+
+done_testing;
diff --git a/t/fun/defaults.t b/t/fun/defaults.t
new file mode 100644
index 0000000..49bd5aa
--- /dev/null
+++ b/t/fun/defaults.t
@@ -0,0 +1,58 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use lib 't/fun/lib';
+
+use Fun;
+
+fun foo ($x, $y = 5) {
+    return $x + $y;
+}
+
+is(foo(3, 4), 7);
+is(foo(3), 8);
+{
+    my $warning;
+    local $SIG{__WARN__} = sub { $warning = $_[0] };
+    is(foo, 5);
+    like($warning, qr/Use of uninitialized value \$x in addition \(\+\)/);
+}
+
+fun bar ($baz, $quux = foo(1) * 2, $blorg = sub { return "ran sub, got " . $_[0] }) {
+    $blorg->($baz + $quux);
+}
+
+is(bar(3, 4, sub { $_[0] }), 7);
+is(bar(5, 6), "ran sub, got 11");
+is(bar(7), "ran sub, got 19");
+{
+    my $warning;
+    local $SIG{__WARN__} = sub { $warning = $_[0] };
+    is(bar, "ran sub, got 12");
+    like($warning, qr/Use of uninitialized value \$baz in addition \(\+\)/);
+}
+
+fun baz ($a, $b = our $FOO) {
+    return "$a $b";
+}
+
+{
+    no warnings 'misc'; # 'not imported' warning because we use $FOO later
+    eval '$FOO';
+    like($@, qr/Global symbol "\$FOO" requires explicit package name/, "doesn't leak scope");
+}
+
+our $FOO = "abc";
+is(baz("123"), "123 abc");
+
+fun goorch ($x, $y = []) {
+    return $y
+}
+
+my $goorch_y_1 = goorch( 10 );
+my $goorch_y_2 = goorch( 10 );
+
+isnt($goorch_y_1, $goorch_y_2, '... not the same reference');
+
+done_testing;
diff --git a/t/fun/lib/Fun.pm b/t/fun/lib/Fun.pm
new file mode 100644
index 0000000..57bea91
--- /dev/null
+++ b/t/fun/lib/Fun.pm
@@ -0,0 +1,157 @@
+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(1);
+            $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;
diff --git a/t/fun/name.t b/t/fun/name.t
new file mode 100644
index 0000000..3294791
--- /dev/null
+++ b/t/fun/name.t
@@ -0,0 +1,48 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use lib 't/fun/lib';
+
+use Carp;
+
+my $file = __FILE__;
+my $line = __LINE__;
+
+{
+    package Foo;
+    use Fun;
+    fun foo ($x, $y) {
+        Carp::confess "$x $y";
+    }
+
+    eval {
+        foo("abc", "123");
+    };
+
+    my $line_confess = $line + 6;
+    my $line_foo = $line + 10;
+
+    ::like($@, qr/^abc 123 at $file line $line_confess\.?\n\tFoo::foo\('abc', 123\) called at $file line $line_foo/);
+}
+
+SKIP: { skip "Sub::Name required", 1 unless eval { require Sub::Name };
+
+{
+    package Bar;
+    use Fun;
+    *bar = Sub::Name::subname(bar => fun ($a, $b) { Carp::confess($a + $b) });
+
+    eval {
+        bar(4, 5);
+    };
+
+    my $line_confess = $line + 24;
+    my $line_bar = $line + 27;
+
+    ::like($@, qr/^9 at $file line $line_confess\.?\n\tBar::bar\(4, 5\) called at $file line $line_bar/);
+}
+
+}
+
+done_testing;
diff --git a/t/fun/package.t b/t/fun/package.t
new file mode 100644
index 0000000..52a2266
--- /dev/null
+++ b/t/fun/package.t
@@ -0,0 +1,17 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use lib 't/fun/lib';
+
+use Fun;
+
+fun Foo::foo ($x, $y) {
+    $x + $y;
+}
+
+ok(!main->can('foo'));
+ok(Foo->can('foo'));
+is(Foo::foo(1, 2), 3);
+
+done_testing;
diff --git a/t/fun/recursion.t b/t/fun/recursion.t
new file mode 100644
index 0000000..75663ec
--- /dev/null
+++ b/t/fun/recursion.t
@@ -0,0 +1,37 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use lib 't/fun/lib';
+
+BEGIN {
+    if (!eval { require 5.016; 1 }) {
+        plan skip_all => "This test requires 5.16";
+    }
+}
+
+use 5.016;
+
+use Fun;
+
+fun fact ($n) {
+    if ($n < 2) {
+        return 1;
+    }
+    return $n * __SUB__->($n - 1);
+}
+
+is(fact(5), 120);
+
+is(fun ($n = 8) { $n < 2 ? 1 : $n * __SUB__->($n - 1) }->(), 40320);
+
+fun fact2 ($n) {
+    if ($n < 2) {
+        return 1;
+    }
+    return $n * fact2($n - 1);
+}
+
+is(fact2(5), 120);
+
+done_testing;
diff --git a/t/fun/slurpy-syntax-errors.t b/t/fun/slurpy-syntax-errors.t
new file mode 100644
index 0000000..90337a5
--- /dev/null
+++ b/t/fun/slurpy-syntax-errors.t
@@ -0,0 +1,29 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use lib 't/fun/lib';
+
+use Fun;
+
+{
+    eval 'fun ( $foo, @bar, $baz ) { return [] }';
+    ok $@, '... got an error';
+}
+
+{
+    eval 'fun ( $foo, %bar, $baz ) { return {} }';
+    ok $@, '... got an error';
+}
+
+{
+    eval 'fun ( $foo, @bar, %baz ) { return [] }';
+    ok $@, '... got an error';
+}
+
+{
+    eval 'fun ( $foo, %bar, @baz ) { return {} }';
+    ok $@, '... got an error';
+}
+
+done_testing;
diff --git a/t/fun/slurpy.t b/t/fun/slurpy.t
new file mode 100644
index 0000000..42a7f10
--- /dev/null
+++ b/t/fun/slurpy.t
@@ -0,0 +1,20 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use lib 't/fun/lib';
+
+use Fun;
+
+fun test_array ( $foo, @bar ) {
+    return [ $foo, @bar ];
+}
+
+fun test_hash ( $foo, %bar ) {
+    return { foo => $foo, %bar };
+}
+
+is_deeply( test_array( 1, 2 .. 10 ), [ 1, 2 .. 10 ], '... slurpy array worked' );
+is_deeply( test_hash( 1, ( two => 2, three => 3 ) ), { foo => 1, two => 2, three => 3 }, '... slurpy hash worked' );
+
+done_testing;
diff --git a/t/fun/state.t b/t/fun/state.t
new file mode 100644
index 0000000..7b8f8fb
--- /dev/null
+++ b/t/fun/state.t
@@ -0,0 +1,18 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use Test::More;
+use lib 't/fun/lib';
+
+use 5.10.0;
+use Fun;
+
+fun bar ($y) {
+    state $x = 10;
+    $x * $y;
+}
+
+is(bar(3), 30);
+
+done_testing;