
use strict;
use warnings;
our $VERSION = '0.01';

use Text::Wigwam::Const qw(:all);

sub _proto_showstruct { [HASH] }
sub _showstruct {
    my ($Api) = @_;
    return DBJ::ShowStruct->new(%{$Api->get_arg}, API => $Api);
}

sub _proto_id_safe { [ STRING ] }
sub _id_safe {
    my $id = $_[0]->get_arg;
    $id =~ s/\]/:cb/g;
    $id =~ s/\[/:ob/g;
    $id =~ s/\\/:bs/g;
    $id =~ s/`/:bt/g;
    return $id;
}

sub _proto_keys_by_type { [ HASH ] }
sub _keys_by_type {
    my ($Api) = @_;
     # Borrow access to the sort_keys_by_type method.
    my $ss = DBJ::ShowStruct->new(API => $Api);
    return [
        $ss->_sort_keys_by_type( $Api->get_arg )
    ];
}

package DBJ::ShowStruct;

use strict;
use warnings;
use Scalar::Util( qw/ refaddr reftype blessed / );

sub new {
    my ($class, %Args) = @_;
    my %args;
    map { $args{uc $_} = $Args{$_} } keys %Args;
    die "API parameter required"
      unless defined $args{API};
    return bless {
        %args,
        SHOWN => {},
    }, ref($class) || $class;
}

sub go {
    my ($self, $name, $struct) = @_;
    no warnings 'uninitialized';
    $self->{SHOWN} = {};
    $name = 'var'. ( $self->_attrib(q/unique/) || '' )
      unless length $name;

    return $self->_dispatch(
        Branch => (
            $name,
            $name,
            $struct,
            0,
            0,
            $self->_do_branch (
                $name,
                $name,
                $struct,
                undef,
                0,
            )
        ),
    );
}

sub _api { $_[0]->{API} }
sub _dispatch {
    my ($self, @args) = @_;
    my $dispatch = $self->_attrib( q/Dispatch/ );
    my ($err, $txt) = $dispatch->execute( [ @args ] );
    die $err if $err;
    return $txt;
}

sub _do_branch {
    my ($self, $name, $show, $struct, $ref, $cur_depth) = @_;
    my $size = $self->_size($struct);
    my $was_seen = $self->_was_seen($name, $struct, $ref);

#    die $self->_traverse($struct).(ref($struct)||$struct);

    my $descent = $self->can( $self->_traverse($struct) )
               && $size;

    my $inactive
        = $was_seen
       || (
               $cur_depth >= $self->_attrib( q/DEPTH/ )
            && $descent
          )
    ;
    my $fold = $cur_depth >= $self->_attrib( q/UNFOLD/ );

    return $self->_dispatch(
         Leaf => (
            $name,
            $show,
            $struct,
            $cur_depth,
            $size && $fold, # /* empty structures are inherently folded */
            $inactive,
            $self->_do_leaf(
                $name,
                $show,
                $struct,
                $ref,
                $cur_depth,
                $fold,
                $inactive,
                $descent,
                $was_seen,
            ),
        ),
    );
}

sub _do_leaf {
    my ($self, $name, $show, $struct, $ref, $cur_depth, $fold, $inactive, $descent, $was_seen) = @_;
        my $refname = $self->_refname($struct);
        my $out = $self->_dispatch(
            Head => $refname => (
                $name,
                $show,
                $struct,
                $cur_depth,
                $inactive,
            ),
        );
        if( $inactive ) {
            return $out.$self->_dispatch(
                Same_As => $was_seen, $cur_depth
            ) if $was_seen;
            return  $out.$self->_dispatch( Too_Deep => $cur_depth )
                 || "(Depth limit reached)"
            ;
        }
        else {
            $out .= $self->_dispatch(
                Summary => $refname => (
                    $name,
                    $show,
                    $struct,
                    $fold,
                    $cur_depth,
                    $ref,
                ),
            );
            return $out unless $descent;
            my $traverse = $self->_traverse($struct);
            return $out . $self->_dispatch(
                Branch => (
                    $name,
                    $show,
                    $struct,
                    $fold,
                    $cur_depth + 1,
                    $self->$traverse(
                        $name,
                        $show,
                        $struct,
                        $cur_depth + 1,
                    ),
                ),
            );
        }
}

sub _traverse {
    my ($self, $struct) = @_;
    return "_traverse_".($self->_refname($struct));
}

sub _refname {
    my ($self, $struct) = @_;
    return 'EXPR'
      if $self->_api->is_expr($struct);
    return reftype $struct || 'STRING';
}

sub _size {
    my ($self, $struct) = @_;
    my $type = reftype $struct or return 1;
    return $struct->size if (
         blessed $struct
         && $struct->isa( q/Text::Wigwam::Expression/ )
    );
    return   $type eq 'HASH'   ? scalar keys %$struct
           : $type eq 'ARRAY'  ? scalar @$struct
           : 1
    ;
}

sub _attrib {
    my ($self, $attrib) = @_;
    die "Nonexistent attribute requested: $attrib"
      unless exists $self->{uc $attrib};
    return $self->{uc $attrib};
}

sub _was_seen {
    my ($self, $name, $struct) = @_;
    my $myid = refaddr $struct
      or return;
    return $self->{SHOWN}{$myid}
      if $self->{SHOWN}{$myid};
    $self->{SHOWN}{$myid} = $name;
    return;
}

sub _traverse_HASH {
    my( $self, $name, $show, $struct, $cur_depth ) = @_;
    my $out;
    my $verbose = $self->_attrib( q/VERBOSE/);
    foreach my $hash_key ($self->_sort_keys_by_type($struct)) {
        my $new_key = $self->_api->escape_var($hash_key);
        my $new_name = "$name.$new_key";
        $out .= $self->_do_branch (
            $new_name,
            $verbose ? $new_name : $new_key,
#            $struct->{$new_key},
            $self->_api->explicit_get_value(
                $struct,
                '.',
                $new_key,
            ),
            undef,
            $cur_depth,
        );
    }
    return $out;
}

sub _sort_keys_by_type {
    my ($self, $hash) = @_;
    my %rank;
    map { $rank{$_} = scalar keys %rank } qw(
        STRING
        SCALAR
        ARRAY
        HASH
        EXPR
        GLOB
        CODE
        IO
        REF
    );
    my $type;
    return
        map { $_->[0] }
             sort {
                  $a->[2] cmp $b->[2] # Rank, then
               || $a->[1] cmp $b->[1] # Type, then
               || $a->[0] cmp $b->[0] # Key
             }
             map {
                [
                    $_,                                 # the key itself
                    $type=$self->_refname($hash->{$_}), # the type
                    $rank{$type},                       # the type's rank
                ]
             } keys %$hash;
}

sub _traverse_ARRAY {
    my( $self, $name, $show, $struct, $cur_depth ) = @_;
#    #unless struct`size #return ""
    my $out;
    foreach my $list_idx (0..$#{$struct}) {
        $out .= $self->_do_branch (
             "$name:$list_idx",
             $self->_attrib(q/VERBOSE/) ? "$name:$list_idx" : $list_idx,
            $struct->[$list_idx],
            undef,
            $cur_depth,
        )
    }
    return $out;
}

sub _traverse_REF {
    my( $self, $name, $show, $struct, $cur_depth ) = @_;
    return $self->_do_branch (
        "$name`deref",
        $self->_attrib(q/VERBOSE/) ? "$name`deref" : "`deref",
        $$struct,
        undef,
        $cur_depth,
    )
}

sub _traverse_GLOB {
    my ($self, $name, $show, $struct, $cur_depth) = @_;
    my $out;
    foreach my $key qw( scalar array hash code ) {
        my $gkey = "G$key";
        $out .= $self->_do_branch (
            "$name`$key",
            $self->_attrib(q/VERBOSE/) ? "$name`$key" : "`$key",
            $self->$gkey($struct),
            undef,
            $cur_depth,
        )
    }
    return $out;
}

sub Gstring { return  ${*{$_[1]}} }
sub Ghash   {
    my (undef, $struct) = @_;
    return defined %{*$struct}  ?  \%{*$struct}  :  undef;
}
sub Garray  {
    my (undef, $struct) = @_;
    return defined @{*$struct}  ?  \@{*$struct}  :  undef;
}
sub Gscalar {
    my (undef, $struct) = @_;
    return defined ${*$struct}  ?  \${*$struct}  :  undef;
}
sub Gcode   {
    my (undef, $struct) = @_;
    return defined &{*$struct}  ?  \&{*$struct}  :  undef;
}

#sub Ghash   { return \%{*{$_[1]}} }
#sub Garray  { return \@{*{$_[1]}} }
#sub Gscalar { return \${*{$_[1]}} }
#sub Gcode   { return \&{*{$_[1]}} }

1;

__END__

The general form of the Schwartzian Transform is:

@sorted = map { $_->[0] }
          sort { $a->[1] cmp $b->[1] }
          map { [$_, foo($_)] }
          @unsorted;

Where foo($_) represents an expression that takes $_ (each item of the list in
turn) and produces the corresponding value that is to be compared in its sake.
