package Perl6::Declare::Util;
use B qw(svref_2object class OPf_MOD OPf_WANT_LIST OPf_KIDS OPf_PARENS OPf_WANT_SCALAR);
use B::Utils;
use B::Generate;

use strict;
use Devel::Caller qw(caller_cv);

use Data::Capture;

use Sub::Exporter -setup => {
    exports => [qw(
        find_caller_spec
        reshuffle
        args_to_capture
        binding_to_shuffled_args
        update_for_caller
        update_caller_argtree
        sig_to_proto
    )],
};

sub null {
    my $op = shift;
    return B::class($op) eq "NULL";
}

sub subarg_is_p {
    my ($op, $cv) = @_;
    # this whole big arse condition is for looking and extract p()
    if ( $op->name eq 'entersub' ) {
        my $sub_name_op = $op->first->first->sibling;
        if ( ( not null $sub_name_op) && $sub_name_op->sibling ) { # not method
            my @n_args;
            for ( ; not null( $sub_name_op->sibling ); $sub_name_op = $sub_name_op->sibling ) { push @n_args, $sub_name_op }
            if ( $sub_name_op->first->name eq 'gv' ) {
                my $gvop = $sub_name_op->first;
                my $idx  = $gvop->padix;
                my $sv   = ( ( $cv->PADLIST->ARRAY )[1]->ARRAY )[$idx];
                if ( $sv->NAME eq 'p' ) {
                    return @n_args;
                    next;
                }
            }
        }
    }
    return;
}

sub find_detachable {
    my ( $parent_cop, $return_op ) = @_;
    my ($parent, $prev, $prevsibling, $thisop, $thisop_prev, $entry);
    no warnings 'redefine';
    local *B::OP::my_visit = sub { my $op = shift;
                                   $thisop = $op if ${$op->next} == $$return_op;
                               };
    B::walkoptree( $_, 'my_visit' ) for $parent_cop->sibling;

    local *B::OP::my_visit = sub { my $op = shift;
                                   $thisop_prev = $op if ${$op->next} == $$thisop;
                                   $parent = $op if $op->can('first') && ${$op->first} == $$thisop;
                                   $prevsibling = $op if ${$op->sibling} == $$thisop;
                                   };
    B::walkoptree( $_, 'my_visit' ) for $parent_cop->sibling, $parent_cop;

    my $visited;
    local *B::OP::my_visit = sub { my $op = shift;
                                   $visited->{$$op} = 1;
                               };
    Carp::confess unless $thisop;
    B::walkoptree( $_, 'my_visit' ) for $thisop;

    local *B::OP::my_visit = sub { my $op = shift;
                                   if (!$visited->{$$op} && $visited->{${$op->next}}) {
                                       $entry = $op->next;
                                       $prev = $op;
                                   }
                               };
    B::walkoptree( $_, 'my_visit' ) for $parent_cop, $parent_cop->sibling;

    return { return => $return_op,
        parent_cop  => $parent_cop,
        thisop      => $thisop,
        thisop_prev => $thisop_prev,
        parent      => $parent,
        prev        => $prev,
        prevsibling => $prevsibling,
        entry       => $entry,
        sibling     => $thisop->sibling->isa('B::NULL') ? undef : $thisop->sibling,
    };
}


sub find_caller_spec {
    my ( $op, $cv ) = @_;
    $op = $op->sibling->first;
    my $pushmark = $op->first;
    $op = $op->first->sibling;    # exlist, pushmark
    my @spec;
    my $narg = 0;
    for ( ; not null $op->sibling; $op = $op->sibling ) {
        if (my @n_args = subarg_is_p($op, $cv)) {
            while ( my ( $key, $value ) = splice( @n_args, 0, 2 ) ) {
                die "p() calls without static arg name ?" unless $key->name eq 'const';

                # pain!
                my $sv = ( ( $cv->PADLIST->ARRAY )[1]->ARRAY )[ $key->targ ];
                push @spec,
                { id => ++$narg,
                  name => ${ $sv->object_2svref },
                  op   => $op,
                };
            }
        }
        else {
            push @spec, { id => ++$narg, op => $op};
        }
    }
    return { spec => \@spec, pushmark => $pushmark};
}

sub find_caller_spec2 {
    my ( $cv, $lv ) = @_;
    my $op = B::OP::parent_op($lv);
    my $caller_op = B::OP::parent_op($lv);
    my $return_op = B::OP::return_op($lv);
    my $tree = find_detachable( $caller_op, $return_op );

    $op = $tree->{thisop}->first;
    my $pushmark = $op->first;
    $op = $op->first->sibling;    # exlist, pushmark
    my @spec;
    my $narg = 0;
    for ( ; not null $op->sibling; $op = $op->sibling ) {
        if (my @n_args = subarg_is_p($op, $cv)) {
            while ( my ( $key, $value ) = splice( @n_args, 0, 2 ) ) {
                die "p() calls without static arg name ?" unless $key->name eq 'const';

                # pain!
                my $sv = ( ( $cv->PADLIST->ARRAY )[1]->ARRAY )[ $key->targ ];
                push @spec,
                { id => ++$narg,
                  name => ${ $sv->object_2svref },
                  op   => $op,
                };
            }
        }
        else {
            push @spec, { id => ++$narg, op => $op};
        }
    }

    return { spec => \@spec, pushmark => $pushmark};
}

sub list_consts {
    my ( $end, $head, @tail ) = @_;

    my $const = new B::SVOP(const => OPf_WANT_SCALAR, $head - 1);
    if (@tail) {
        my @rest = list_consts($end, @tail);
        $const->$_($rest[0]) for qw(next sibling);
    } else {
        $const->next($end);
        $const->sibling(undef);
    }

    return $const;
}

sub rewrite_p_args {
    my ($op, $cv) = @_;
    for (; not null $op->sibling; $op = $op->sibling) {
        if (my @n_args = subarg_is_p($op->sibling, $cv)) {
            my $next = $op->sibling->sibling;
            while ( my ( $key, $value ) = splice( @n_args, 0, 2 ) ) {
                $op->sibling( $value );
                $op->next($value);
                $op = $value;
            }
            $op->sibling($next);
            $op->next($next);
        }
    }
}

my $alt_entry_point;
sub compile_alt_entry_point {

    my $cv = svref_2object(shift);
    for ($cv->ROOT->first->kids) {
        return ($alt_entry_point = $_, $cv) if $_->name eq 'nextstate' && $_->label eq '___P6D_SIGSTART';
    }

    die "can't find my belly button";
}

sub update_for_caller {
    my ($sig, $lv) = @_;
    $lv ||= 1;
    my $cv = caller_cv($lv+1);
    update_caller_argtree( compile_alt_entry_point(caller_cv($lv)),
                           $cv ? svref_2object($cv) : B::main_cv, $sig, $lv+1 );
}

sub update_for_caller_test {
    my ($sig, $lv) = @_;
    $lv ||= 1;
    my $cv = caller_cv($lv+1);
    update_caller_argtree_test( compile_alt_entry_point(caller_cv($lv)),
                           $cv ? svref_2object($cv) : B::main_cv, $sig, $lv+1 );
    return;
}

sub update_caller_argtree_test {
    my ( $entry, $target, $cv, $sig, $lv ) = @_;
    my $caller_struct = find_caller_spec2( $cv, $lv + 1 );
    my $spec          = $caller_struct->{spec};
    my $gv            = $spec->[-1]{op}->next;
    my $leavesub = B::UNOP->new("leavesub", $cv->ROOT->flags, $cv->ROOT->first);
    my $nextstate = $cv->START;
    my $newcv = $target->NEW_with_start($leavesub, $entry);
    my $last_arg = $caller_struct->{pushmark}->sibling;
    $last_arg = $last_arg->sibling
        while not null $last_arg->sibling->sibling;
#return;
    my $const = B::SVOP->new_svrv( "const", 0, $newcv->object_2svref );
#return;
    $const->next($gv->next);
    $last_arg->next($const);

#    B::Concise::compile('-basic',$newcv->object_2svref)->();

    return;
}

my @blah;

sub update_caller_argtree {
    my ( $entry, $target, $cv, $sig, $lv ) = @_;
    my $caller_struct = find_caller_spec2( $cv, $lv + 1 );
    my $spec          = $caller_struct->{spec};
    my $rv2cv         = $spec->[-1]{op}->sibling;
    my $gv            = $spec->[-1]{op}->next;
    unless ($gv->name eq 'gv') {
        # if the caller's entersub is not a gv, which can be a padsv
        # or something, we can't update the caller's optree obviously,
        # because the sv might not be us the next time it is invoked.
        # warn "can't be crazy, caller too sane.";
        return;
    }

    my $pushmark      = new B::OP( "pushmark", 0 );
    my @new_order     = reshuffle($sig, @$spec);

    my $i = 0;
    use List::MoreUtils 'firstidx';

    # XXX: reshuffle should prover this structure
    my @inverse;
    for my $x (1..$#new_order+1) {
        push @inverse, (firstidx { $_ == $x } @new_order) + 1,
    }
    my $struct = [map { [ $inverse[$i++], $_->is_copy ? 1 : 0, $_->default, $_->name ] }
                  map { $sig->[0]->named->{$_} }
                  map { substr($_, 1) } $sig->all_variable_names];

    my $our_special_pad_binder = Data::Bind::OP_bind_pad2(0, $struct);
    $our_special_pad_binder->next($entry);

#    warn $our_special_pad_binder;
    my $nextstate = B::COP->new("nextstate",
#                                scalar $target->START->flags,
                                "moose",
                                $our_special_pad_binder);
    $nextstate->next($our_special_pad_binder);
    my $lineseq = new B::LISTOP("lineseq", $target->ROOT->first->flags, $nextstate, $target->ROOT->first->first);

    my $leavesub = new B::UNOP("leavesub", $target->ROOT->flags, $nextstate );
    my $newcv = $target->NEW_with_start($leavesub, $nextstate);

    rewrite_p_args( $caller_struct->{pushmark}, $cv );
    my $last_arg = $caller_struct->{pushmark}->sibling;
    $last_arg = $last_arg->sibling
        while not null $last_arg->sibling->sibling;

    # replace the rv2cv and gv with const pointing to newcv
    my $const = B::SVOP->new_svrv( "const", 64, $newcv->object_2svref );
    $const->next($gv->next);
    $last_arg->next($const);

    return;
    use B::Concise qw(set_style add_callback);
    use B::Terse;
#    print "DONE===>\n";
#    use B::Deparse;
    B::Concise::compile('-basic',$cv->object_2svref)->();
    B::Concise::compile('-exec',$cv->object_2svref)->();
    B::Concise::compile('-basic',$newcv->object_2svref)->();
#    warn B::Deparse->new->coderef2text($cv->object_2svref);
#    B::Concise::compile('-basic',$target->object_2svref)->();

}

sub reshuffle {
    my ( $sig, @arg_spec ) = @_;
    
    my $capture = args_to_capture(@arg_spec);

    my $binding = $sig->prepare_binding($capture, no_default => 1);

    binding_to_shuffled_args( $sig, $binding );
}

sub args_to_capture {
    my ( @arg_spec ) = @_;

    my ( @pos, %named );

    foreach my $elem ( @arg_spec ) {
        die "Flattenning not yet supported" if $elem->{flat};

        if ( my $name = $elem->{name} ) {
            $named{$name} = $elem;
        } else {
            push @pos, $elem;
        }
    }

    Data::Capture->new( positional => \@pos, named => \%named );
}

sub binding_to_shuffled_args {
    my ( $sig, $binding ) = @_;

    my @names = $sig->all_variable_names;

    map { $_ && $_->[1]{id} } @{ $binding }{@names};
}

__PACKAGE__
