#!/usr/bin/env perl

use strict;
use warnings FATAL => 'uninitialized';
use utf8;
use experimental 'signatures';

use Cwd 'abs_path';

my ($mydir, $myname);

BEGIN {
    my $location = (-l $0) ? abs_path($0) : $0;
    $location =~ /(.*?)([^\/]+)\z/s or die "?";
    ($mydir, $myname) = ($1, $2);
}

use lib "$mydir/../lib";

use Chj::xtmpfile;
use Chj::xopen 'xopen_read';
use Chj::TEST;
use List::Util 'pairkeys';

(my $email = 'ch%christianjaeger,ch') =~ tr/%,/@./;

sub usage {
    print STDERR map {"$_\n"} @_ if @_;
    my $ops = join("", map {"    $_\n"} pairkeys ops());
    print "Usage: $myname --op opname [--op opname ...] file...

  opname can be any of:
$ops
  (Christian Jaeger <$email>)
";
    exit(@_ ? 1 : 0);
}

use Getopt::Long;
my $verbose = 0;
my @opt_op;
my $opt_test;
my $opt_repl;

#our $opt_dry;
GetOptions(
    "verbose" => \$verbose,
    "help"    => sub {usage},
    "op=s"    => sub {
        my (undef, $val) = @_;
        push @opt_op, $val;
    },
    "test" => \$opt_test,
    "repl" => \$opt_repl,

    #"dry-run"=> \$opt_dry,
) or exit 1;

sub protos_to_arity ($str) {
    my @p     = grep { length $_ } split /\s*/, $str;
    my $s     = join('', @p);
    my @parts = split /;/, $s;
    my $l0    = length($parts[0]);
    if (@parts == 1) {
        [$l0]
    } elsif (@parts == 2) {
        my $l1 = length($parts[1]);
        [$l0, $l0 + $l1]
    } elsif (@parts == 0) {
        [0]
    } else {
        die "invalid prototype decl: '$s'"
    }
}

TEST { protos_to_arity '$' } [1];
TEST { protos_to_arity ' $  $$' } [3];
TEST { protos_to_arity '$$ ; $' } [2, 3];
TEST { protos_to_arity '&$' } [2];
TEST { protos_to_arity '@$' } [2];
TEST { protos_to_arity '' } [0];

sub checkcode_for_arity ($arity) {
    my ($min, $maybe_max) = @$arity;
    if (!defined $maybe_max) {
        "\@_ == $min or fp_croak_arity $min;\n"
    } else {
        "\@_ >= $min and \@_ <= $maybe_max or fp_croak_arity \"$min-$maybe_max\";\n"
    }
}

my $compare_re = qr(<|>|<=|>=|==);

my %rising  = map { $_ => 1 } qw(> >=);
my %falling = map { $_ => 1 } qw(< <=);
my %equal   = map { $_ => 1 } qw(==);

sub compare_range {
    my ($compare1, $n1, $maybe_andor, $maybe_compare2, $maybe_n2) = @_;
    if (defined $maybe_andor) {
        if ($maybe_andor eq '&&' or $maybe_andor eq 'and') {
            if ($rising{$compare1} and $falling{$maybe_compare2}) {
                "$n1-$maybe_n2"
            } else {
                die "don't know how to handle '$compare1 and $maybe_compare2'"
            }
        } elsif ($maybe_andor eq '||' or $maybe_andor eq 'or') {
            if ($equal{$compare1} and $equal{$maybe_compare2}) {
                "$n1 or $maybe_n2"
            } else {

                # XX could simply say "$compare1 $n1 or $maybe_compare2
                # $maybe_n2" or 'optimize' it in the cases where it's
                # ==
                die "don't know how to handle '$compare1 and $maybe_compare2'"
            }
        } else {
            die "invalid andor: $maybe_andor"
        }
    } else {
        $compare1 eq "==" ? $n1 : "$compare1 $n1"
    }
}

TEST { compare_range qw(> 5) } '> 5';
TEST { compare_range qw(<= 5) } '<= 5';
TEST { compare_range qw(== 5) } '5';
TEST_EXCEPTION { compare_range qw(== 5 and == 6) }
'don\'t know how to handle \'== and ==\'';
TEST { compare_range qw(== 5 or == 6) } '5 or 6';
TEST_EXCEPTION { compare_range qw(== 5 or > 6) }
'don\'t know how to handle \'== and >\'';

our $current_file;

sub ops () {
    (

        # [ needs_whole_file, proc ]
        opspaces => [
            0,
            sub {
                if (/http|href/) {
                    $_
                } else {
                    s{ ([^/>=~<!|+*-]) (=|=>|==|=~|/=|//=|>=|<=|<<|>>|!=|\|\||\|\|=|\+=|-=|\*=) ([^/>=~<!|]) }{
                        my ($a,$b,$c)=($1,$2,$3);
                        my $all = "$a$b$c";
                        my $pre= substr($_, 0, pos($_)+1);
                        my $is_perl = 0;
                        if ($b eq "=>") {
                            $is_perl = 1
                        } elsif (not substr($pre, length($pre)-1, 1)=~ /\w/) {
                            $is_perl = 1
                        } elsif (my ($sigil) = $pre =~ /([^\w])[A-Za-z_]\w*\s*$/) {
                            $is_perl= $sigil =~ /[\$*&@%]/
                        }
                        #use FP::Repl;repl;
                        if ($is_perl) {
                            ($a eq " " ? $a : "$a ").$b.($c eq " " ? $c : " $c")
                        } else {
                            $all
                        }
                    }sgex and s/[ \t]*$//;
                    $_
                }
            }
        ],

        functionparameters2signatures => [
            1,
            sub {
                s{
                     \b(method|fun)(\s+\w+)
                     (?:
                         (\s*\(\s*)
                         ([^()]*?)
                         (\s*\))
                     )?
                     (\s*\{)
                }{
                    my ($which,$name,$a,$b,$c,$end)=($1,$2,$3,$4,$5,$6);
                    "sub$name"
                      . ($which eq "method" ? 
                         (defined($b) ? $a.(length($b) ? q{$self, }.$b : q{$self}).$c
                          : q{($self)})
                         : "$a$b$c")
                      . $end
                }sgex;
                $_
            }
        ],

        excise_prototypes => [
            1,
            sub {
                return $_
                    if /use +experimental [^\n;]*signatures[^\n;]*;/
                    ;    # since `()` is ambiguous
                s{
                     ( \bsub\b \ *)(\w+)?( \ * )
                     \( ([\@\$; ]*) \)  # do *not* include & here, as those are needed
                     ( \s* \{ \s* )
                     ( (?:[^\n]*\n){0,2} )
                }{
                    my ($_pre, $maybe_name, $_post, $protos, $post, $bodystart)
                      = ($1,$2,$3,$4,$5,$6);
                    my $pre = $_pre . ($maybe_name // "") . $_post;

                    if (defined $maybe_name and $maybe_name =~ /^[A-Z0-9_]+\z/
                        and $protos =~ /^\s*\z/ and $bodystart =~ /^\s*\d+\}/) {
                        # constant, leave as is
                        "$pre($protos)$post$bodystart"
                    } else {
                        # make sure bodystart doesn't slurp over a subsequent definition
                        die "accidentally slurping up subsequent definition"
                          if $bodystart =~ /(\bsub\b \ *(?:\w+)?) \ * (?:\([@$&;]*\))? (\s* \{)/;

                        my $checkcode = do {
                            if ($bodystart =~ /\@_ *(?:==|<=|>=|<|>) *\d+/) {
                                ""
                            } else {
                                checkcode_for_arity(protos_to_arity($protos))
                            }
                        };
                        # Make sure there's no empty line before the checkcode
                        my $post_and_checkcode = "$post$checkcode";
                        $post_and_checkcode =~ s/^(\s*\{)[ \t]*\n\s*/$1\n    /s;
                        "$pre$post_and_checkcode    $bodystart"
                    }
                }sgex;
                $_
            }
        ],

        move_to_fp_croak_arity => [
            1,
            sub {
                my $replacements = s{
                 ( ; | \{ \s* )
                 ( \(? \s* \@_ \s* ($compare_re) \s* (\d+) \s*
                     (?: ( and | && | or | \|\| ) \s* \@_ \s* ($compare_re) \s* (\d+) )? \s* \)?  \s* )
                 ( or \s+ (?:die|(?:\w+::)*croak) \s*
                     (?: "[^"]*wrong\ number\ of\ arguments[^"]*" |
                         "[^"]*(?:expecting|expects|needs?) \s+ \d+
                            (?: \ * (?:-|to) \ * \d+)? \s+ (?:parameter|argument)s?[^"]*" |
                         "[^"]*not\ enough\ arguments[^"]*"
                     ) \s* ;)
                }{
                    my ($pre, $compare, $compare1, $n1, $maybe_andor, $maybe_compare2, $maybe_n2, $or_part)
                      = ($1,$2,$3,$4,$5,$6,$7,$8);
                    my $range = compare_range($compare1, $n1, $maybe_andor, $maybe_compare2, $maybe_n2);
                    unless ($range =~ /^\d+$/s) {
                        $range = "\"$range\"";
                    }
                    "$pre$compare or fp_croak_arity $range;"
                }sgex;
                if ($replacements) {
                    unless (/use FP::Carp/) {
                        do {
                            if (/[\@\%]EXPORT/) {

                                # force it after 'EXPORT'
                                s{(.*[\@\%]EXPORT.*\nuse [A-Z][^;\n]+;[^\n]*\n)}{${1}use FP::Carp;\n}s
                            } else {
                                s{(.*\nuse [A-Z][^;\n]+;[^\n]*\n)}{${1}use FP::Carp;\n}s
                            }
                            }
                            or warn
                            "could not insert FP::Carp into $current_file\n";
                    }
                }
                $_
            }
        ],
    )
}

my %ops = ops;

sub run {
    @opt_op or usage "no op given, use the --op option";

    my @op = map { $ops{$_} // die "unknown op '$_'" } @opt_op;

    my %needs_whole_file = map { $_->[0] ? (1 => undef) : (0 => undef) } @op;

    (keys %needs_whole_file) == 1
        or die
        "can't satisfy ops of different needs_whole_file requirement at the same time";

    my ($needs_whole_file) = keys %needs_whole_file;

    for my $file (@ARGV) {
        local $current_file = $file;
        my $f     = xopen_read $file;
        my @lines = do {
            local $/ = $needs_whole_file ? undef : $/;
            $f->xreadline;
        };
        $f->xclose;

        my $t = xtmpfile $file;
        $t->xprint(
            map {
                for my $op (@op) {
                    my (undef, $proc) = @$op;
                    $_ = &$proc($_);
                }
                $_
            } @lines
        );
        $t->xclose;
        $t->xputback;
    }
}

if ($opt_test) {
    Chj::TEST::run_tests(__PACKAGE__);
} elsif ($opt_repl) {
    require FP::Repl;
    FP::Repl->import("repl");
    repl();
} else {
    run
}

