The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

package Devel::Declare::Lexer::t;

use strict;
use warnings;
use Devel::Declare::Lexer qw/ test function /;

use Test::More;

#BEGIN { $Devel::Declare::Lexer::DEBUG = 1; }

my $tests = 0;

BEGIN {
    Devel::Declare::Lexer::lexed(test => sub {
        my ($stream_r) = @_;
        return $stream_r;
    });
    Devel::Declare::Lexer::lexed(function => sub {
        my ($stream_r) = @_;

        my @stream = @{$stream_r};
        my @start = @stream[0..1];
        my @end = @stream[2..$#stream];

        my @output;
        tie @output, 'Devel::Declare::Lexer::Stream';

        shift @stream; # remove keyword
        shift @stream; # remove whitespace
        my $name = shift @stream; # get function name

        my @vars = ();
        while($stream[0]->{value} !~ /{/) {
            my $tok = shift @stream;
            next if ref($tok) =~ /Devel::Declare::Lexer::Token::(Left|Right)Bracket/;
            next if ref($tok) =~ /Devel::Declare::Lexer::Token::Operator/;
            next if ref($tok) =~ /Devel::Declare::Lexer::Token::Whitespace/;
           
            if(ref($tok) =~ /Devel::Declare::Lexer::Token::Variable/) {
                push @vars, [
                    $tok,
                    shift @stream
                ];
            }
        }

        push @output, @start;
        # Terminate the existing statement
        push @output, new Devel::Declare::Lexer::Token::Bareword( value => '1' );
        push @output, new Devel::Declare::Lexer::Token::EndOfStatement( value => ';' );

        # Add the sub keyword/name
        push @output, new Devel::Declare::Lexer::Token::Bareword( value => 'sub' );
        push @output, new Devel::Declare::Lexer::Token::Whitespace( value => ' ' );
        push @output, $name;
        push @output, new Devel::Declare::Lexer::Token::Whitespace( value => ' ' );

        # Output the 'my (...) = @_;' line
        push @output, new Devel::Declare::Lexer::Token::Whitespace( value => ' ' );
        push @output, shift @stream; # consume the {
        push @output, new Devel::Declare::Lexer::Token::Bareword( value => 'my' );
        push @output, new Devel::Declare::Lexer::Token::Whitespace( value => ' ' );
        push @output, new Devel::Declare::Lexer::Token::LeftBracket( value => '(' );
        for my $var (@vars) {
            push @output, @$var;
            push @output, new Devel::Declare::Lexer::Token::Operator( value => ',' );
        }
        pop @output; # one too many commas
        push @output, new Devel::Declare::Lexer::Token::RightBracket( value => ')' );
        push @output, new Devel::Declare::Lexer::Token::Whitespace( value => ' ' );
        push @output, new Devel::Declare::Lexer::Token::Operator( value => '=' );
        push @output, new Devel::Declare::Lexer::Token::Whitespace( value => ' ' );
        push @output, new Devel::Declare::Lexer::Token::Variable( value => '@_' );
        push @output, new Devel::Declare::Lexer::Token::EndOfStatement( value => ';' );

        # Stick everything else back on the end
        push @output, @stream;

        return \@output;
    });
}

my $s;
test $s = sub {
    my $a = shift;
    my $b = shift;
    my $c = $a + $b;
    $c *= 5;
    return $c;
};
++$tests && is(&$s(1,2), 15, 'Multiline subs');

# This is a bit strange.
# What actually happens is the lexer only gets as far as the first semi-colon on the second line, then exits.
# Its fine because the rest doesn't matter, for this example, and all remaining lines are left intact!
# 
# This also means that any Lexer keywords used after the first line of the function will get parsed properly
#
# FIXME this probably means the lexers understanding of blocks needs improving - i.e., nested bracket tracking
# TODO add a callback to control when the lexer ends, so we can stop at the first {
# (or skip past the first ;?
function something ($a, $b) {
    return 5 * ($a + $b);
};
++$tests && is(something(1,2), 15, 'Function definition');

++$tests && is(__LINE__, 109, 'Line numbering (CHECK WHICH LINE THIS IS ON)');

done_testing $tests;

#100 / 0;