#
# This file is part of StorageDisplay
#
# This software is copyright (c) 2014-2023 by Vincent Danjean.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
use strict;
use warnings;

package StorageDisplay::Role;
# ABSTRACT: Load all roles used in StorageDisplay

our $VERSION = '2.01'; # VERSION

1;

##################################################################
package StorageDisplay::Role::ProvideName::Plain;

use Moose::Role;

sub name; # forward decl for 'requires'
has 'name' => (
    is       => 'ro',
    isa      => 'Str',
    init_arg => 'name',
    required => 1,
    );

1;

##################################################################
package StorageDisplay::Role::ProvideName::Recursive;

use Moose::Role;
use Carp;

requires 'has_parent';

has '_name' => (
    is       => 'ro',
    isa      => 'Str',
    init_arg => 'name',
    required => 1,
    lazy     => 1,
    default  => sub {
	my $self = shift;
	if (!$self->ignore_name) {
	    confess "no name provided and ignore_name not set in $self\n";
	}
	return "NONAME";
    },
    );

sub name; # forward decl for 'requires'
has 'name' => (
    is       => 'ro',
    isa      => 'Str',
    init_arg => undef,
    required => 1,
    lazy     => 1,
    default  => sub {
	my $self = shift;
	my $lname = $self->name_prefix;
	if (!$self->ignore_name) {
	    $lname .= '@'.$self->_name;
	}
	#print STDERR "In $self\t: using $lname as name\n";
	return $lname;
    },
    );

has 'fullname' => (
    is       => 'ro',
    isa      => 'Str',
    init_arg => undef,
    required => 1,
    lazy     => 1,
    default  => sub {
	my $self = shift;
	my $lname = $self->fullname_prefix;
	if (!$self->ignore_name) {
	    $lname .= '@'.$self->_name;
	}
	if (! $self->has_parent) {
	    #print STDERR "no parent in fullname for $self\n";
	    return $lname;
	}
	my $fullname = join('|', $self->parent->fullname, $lname);
	#print STDERR "In $self\t: using $fullname as fullname\n";
	return $fullname;
    },
    );

has 'name_prefix' => (
    is       => 'ro',
    isa      => 'Str',
    required => 1,
    lazy     => 1,
    default  => sub {
	my $self = shift;
	my $kind = ref($self);
	$kind =~ s/^StorageDisplay::Data:://;
	return $kind;
    },
    );

has 'fullname_prefix' => (
    is       => 'ro',
    isa      => 'Str',
    init_arg => undef,
    required => 1,
    lazy     => 1,
    default  => sub {
	my $self = shift;
	my $kind = ref($self);
	$kind =~ s/^StorageDisplay::Data:://;
	my $name_prefix = $self->name_prefix;
	if ($kind ne $name_prefix) {
	    return $name_prefix;
	}
	if ($self->has_parent) {
	    my $pkind = ref($self->parent);
	    $pkind =~ s/^StorageDisplay::Data:://;
	    $kind =~ s/^$pkind//;
	}
	return $kind;
    },
    );

has 'ignore_name' => (
    is       => 'ro',
    isa      => 'Bool',
    required => 1,
    lazy     => 1,
    default  => 0,
    );

1;

##################################################################
package StorageDisplay::Role::WithName;

use Moose::Role;

requires 'name';

1;

##################################################################
package StorageDisplay::Role::Iterable;

use MooseX::Role::Parameterized;
use Types::Standard qw(Enum);

use Carp;

parameter iterable => (
    isa      => 'Str',
    required => 1,
    );

parameter _kindname => (
    is       => 'ro',
    isa      => Enum[qw/Plain Recursive/],
    init_arg => 'name',
    required => 1,
    #default  => "Plain",
    );

role {
    my $p = shift;
    my $role_provide = "StorageDisplay::Role::ProvideName::".$p->_kindname;

    with (
	$role_provide,
	"StorageDisplay::Role::WithName",
	);

    my $iterable = $p->iterable;
    my $iterator = $iterable.'::Iterator';
    my $iteratorframe = $iterator.'::Frame';

    has '_parents' => (
        traits   => [ 'Hash' ],
        is       => 'ro',
        isa      => "HashRef[$iterable]",
        required => 1,
        default  => sub { return {}; },
        handles  => {
            '_add_parents' => 'set',
                'hasParent' => 'exists',
                '_getParent' => 'get',
        }
        );

    has '_parents_tab' => (
        traits   => [ 'Array' ],
        is       => 'ro',
        isa      => "ArrayRef[$iterable]",
        required => 1,
        default  => sub { return []; },
        handles  => {
            '_add_parents_tab' => 'push',
                'parents' => 'elements',
		'nb_parents' => 'count',
        }
        );

    method "_addParent" => sub {
        my $self = shift;
        my $parent = shift;
        my $parent_name = $parent->name;
        if ($self->hasParent($parent_name)) {
            if ($parent != $self->_getParent($parent_name)) {
                croak "Two different parents with name $parent_name for ".$self->name;
            }
        } else {
            $self->_add_parents($parent_name, $parent);
            $self->_add_parents_tab($parent);
        }
    };

    has '_children' => (
        traits   => [ 'Hash' ],
        is       => 'ro',
        isa      => "HashRef[$iterable]",
        required => 1,
        default  => sub { return {}; },
        handles  => {
            '_addChild' => 'set',
                'hasChild' => 'exists',
                '_getChild' => 'get',
        }
        );

    has '_children_tab' => (
        traits   => [ 'Array' ],
        is       => 'ro',
        isa      => "ArrayRef[$iterable]",
        required => 1,
        default  => sub { return []; },
        handles  => {
        '_addChild_tab' => 'push',
            'children' => 'elements',
        }
        );

    method "addChild" => sub {
        my $self = shift;
        my $child = shift;
        my $child_name = $child->name;
        if ($self->hasChild($child_name)) {
            if ($child != $self->_getChild($child_name)) {
                croak "Two different children with name $child_name for ".$self->name;
            }
        } else {
            $self->_addChild($child_name, $child);
            $self->_addChild_tab($child);
        }
        $child->_addParent($self);
        return $child;
    };

    method "iterator" => sub {
        my $self = shift;

        return "$iterator"->new(
            $self,
            @_,
            );
    };
    ######################################################
    ######################################################
    # ::Iterator class
    my $iteratorclass = Moose::Meta::Class->create(
        $iterator,
        #attributes => [],
        #roles => [],
        #methods => {},
        superclasses => ["Moose::Object"],
        );

    $iteratorclass->add_attribute(
        'recurse' => (
            is  => 'ro',
            isa => 'Bool',
            required => 1,
            default => 1,
        ));
    $iteratorclass->add_attribute(
        'with-self' => (
            is  => 'bare',
            reader => 'with_self',
            isa => 'Bool',
            required => 1,
            default => 0,
        ));
    $iteratorclass->add_attribute(
        '_seen' => (
            traits => [ 'Hash' ],
            is  => 'ro',
            isa => 'HashRef[Bool]',
            required => 1,
            default => sub { return {}; },
            handles  => {
                '_found' => 'exists',
                    '_mark' => 'set',
            }
        ));
    $iteratorclass->add_attribute(
        'uniq' => (
            is  => 'ro',
            isa => 'Bool',
            required => 1,
            default => 0,
        ));
    $iteratorclass->add_attribute(
        'postfix' => (
            is => 'ro',
            isa => 'Bool',
            required => 1,
            default => 0,
        ));
    $iteratorclass->add_attribute(
        '_stack_frame' => (
            traits => [ 'Array' ],
            is  => 'ro',
            isa => "ArrayRef[$iteratorframe]",
            required => 1,
            default => sub { return []; },
            handles  => {
                '_push_frame' => 'push',
                    '_pop_frame' => 'pop',
            }
        ));
    $iteratorclass->add_attribute(
        '_init_block' => (
            is  => 'ro',
            isa => $iterable,
            required => 1,
        ));
    $iteratorclass->add_attribute(
        '_cur_frame' => (
            is  => 'rw',
            isa => "Maybe[$iteratorframe]",
            required => 1,
            lazy => 1,
            default => sub {
                my $self = shift;
                return $iteratorframe->new(
                    $self->_init_block,
                    $self,
                    );
            },
        ));
    $iteratorclass->add_attribute(
        '_next_computed' => (
            is  => 'rw',
            isa => 'Bool',
            required => 0,
            default => 0,
        ));
    $iteratorclass->add_attribute(
        '_next' => (
            is  => 'rw',
            isa => "Maybe[$iterable]",
            required => 0,
            default => undef,
        ));
    $iteratorclass->add_method(
        'has_next' => sub {
            my $self = shift;
            if (! $self->_next_computed) {
                $self->_compute_next;
            }
            return defined($self->_next);
        });
    $iteratorclass->add_method(
        'next' => sub {
            my $self = shift;
            if (! $self->_next_computed) {
                $self->_compute_next;
            }
            $self->_next_computed(0);
            return $self->_next;
        });
    $iteratorclass->add_attribute(
        'filter' => (
            traits  => ['Code'],
            is      => 'ro',
            isa     => 'CodeRef',
            default => sub {
                sub { 1; }
            },
            handles => {
                do_filter => 'execute',
            },
        ));
    $iteratorclass->add_method(
        '_compute_next' => sub {
            my $self = shift;

            $self->_next_computed(1);
            if (!defined($self->_cur_frame)) {
                $self->_next(undef);
                return;
            }
            #print STDERR "****\nBegin compute: ", $self->_cur_frame->dump, "\n";
            do {
                do {
                    my $n = $self->_cur_frame->next_child;
                    while (! defined($n)) {
                        # nothing more in this frame. Poping it.
                        my $cur_frame = $self->_cur_frame;
                        $self->_cur_frame($self->_pop_frame);
                        if ($self->postfix) {
                            $n=$cur_frame->current;
                            #print STDERR "Poping frame and found: ", $n->name, "\n";
                            if ($n == $self->_init_block) {
                                $self->_next(undef);
                                return;
                            }
                            $self->_next($n);
                            $n=undef;
                            last;
                        } else {
                            if (!defined($self->_cur_frame)) {
                                $self->_next(undef);
                                return;
                            }
                            #print STDERR "Poping frame: ", $self->_cur_frame->dump, "\n";
                            $n = $self->_cur_frame->next_child;
                        }
                    }
                    while (defined($n)) {
                        # $n : next in _cur_frame
                        my @children = ($n->children);
                        if (! $self->recurse || scalar(@children) == 0) {
                            # no children for current node (or no recursion), just using it and go
                            $self->_next($n);
                            #print STDERR "Found no children: ", $n->name, "\n";
                            last;
                        } else {
                            # Building new frame
                            my $new_frame = $iteratorframe->new(
                                $n,
                                $self,
                                );
                            #print STDERR "Building new frame: ", $new_frame->dump, "\n";
                            $self->_push_frame($self->_cur_frame);
                            $self->_cur_frame($new_frame);
                            if (! $self->postfix) {
                                $self->_next($n);
                                last;
                            } else {
                                $n = $new_frame->next_child;
                            }
                        }
                    }
                } while ($self->uniq && $self->_found($self->_next));
                $self->_mark($self->_next, 1);
                #FIXME# if not a real bloc, accept it
                #last if not $self->_next->isa($iterable);
            } while (
                ($self->with_self || $self->_next != $self->_init_block)
                && !$self->do_filter($self->_next)
                );


            #if ($self->has_next) {
            #    print STDERR "Found: ", $self->_next->name, "\n";
            #}
            #use Data::Dumper;
            #$Data::Dumper::Maxdepth = 3;
            #print STDERR Dumper($self);
        });
    $iteratorclass->add_around_method_modifier(
        'BUILDARGS' => sub {
            my $orig  = shift;
            my $class = shift;
            my $init_block = shift;
            my %args = (@_);

            return $class->$orig(
                @_,
		'_init_block' => $init_block,
                );
        });
    ######################################################
    ######################################################
    # ::Iterator::Frame class
    my $iteratorframeclass = Moose::Meta::Class->create(
        $iteratorframe,
        #attributes => [],
        #roles => [],
        #methods => {},
        superclasses => ["Moose::Object"],
        );
    $iteratorframeclass->add_attribute(
        'current' => (
            is  => 'ro',
            isa => $iterable,
            required => 1,
        ));
    $iteratorframeclass->add_attribute(
        '_children' => (
            traits => [ 'Array' ],
            is  => 'ro',
            isa => "ArrayRef[$iterable]",
            required => 1,
            handles  => {
                'next_child' => 'shift',
                    '_all_children' => 'elements',
            }
        ));
    $iteratorframeclass->add_attribute(
        'it' => (
            is  => 'ro',
            isa => $iterator,
            required => 1,
        ));
    $iteratorframeclass->add_around_method_modifier(
        'BUILDARGS' => sub {
            my $orig  = shift;
            my $class = shift;
            my $current = shift;
            my $it = shift;

            return $class->$orig(
                'current' => $current,
                'it' => $it,
                '_children' => [ $current->children ],
		@_
                );
        });
};

1;

package StorageDisplay::Role::Elem::Kind;

use MooseX::Role::Parameterized;

parameter kind => (
    isa      => 'Str',
    required => 1,
    );

role {
    my $role = shift;

    my $kind = $role->kind;

    around 'BUILDARGS' => sub {
	my $orig  = shift;
	my $class = shift;

	return $class->$orig(@_, 'name_prefix' => $kind);
    };
};

1;

##################################################################
package StorageDisplay::Role::HasBlock;

use Moose::Role;

has 'block' => (
    is       => 'ro',
    isa      => 'StorageDisplay::Block',
    required => 1,
    );

1;

##################################################################
package StorageDisplay::Role::Style::Base;

use Moose::Role;

1;

##################################################################
package StorageDisplay::Role::Style::Base::Elem;

use Moose::Role;

use Carp;

sub dotJoinStyle {
    my $self = shift;
    my $t = shift // "\t";

    return join(';', grep { defined($_) } @_);
}

sub dotIndent {
    my $self = shift;
    my $t = shift // "\t";

    return map { $t.$_ } @_;
}

sub dotLabel {
    my $self = shift;
    return ($self->_dotDefaultLabel(@_));
}

sub dotFullLabel {
    my $self = shift;
    return $self->_dotDefaultFullLabel(@_);
}

sub dotNode {
    my $self = shift;
    #print STDERR "dotNode in ".__PACKAGE__." for ".$self->name."\n";
    return $self->_dotDefaultNode(@_);
}

sub dotStyleNode {
    my $self = shift;
    return $self->_dotDefaultStyleNode(@_);
}

sub dotStyleNodeState {
    my $self = shift;

    return $self->_dotDefaultStyleNodeState;
}

sub dotFormatedFullLabel {
    my $self = shift;
    my $t = shift;

    return join($self->_dotLabelNL,
                $self->dotFullLabel);
}

# default implementations

# will be overrided when a Table is generated
sub _dotTableLabel {
    my $self = shift;
    return $self->dotFormatedFullLabel(@_);
}

sub _dotDefaultLabel {
    my $self = shift;
    return ($self->name);
}

sub _dotDefaultStyleNodeState {
    my $self = shift;

    return ();
}

sub _dotDefaultStyleNode {
    my $self = shift;
    my @style = grep { $_ !~ m/[node]/ } $self->dotStyle(@_);

    push @style, $self->dotStyleNodeState(@_);
    return @style;
}

sub _dotLabelNL {
    my $self = shift;
    return '\n';
}

# will be overrided with Size, Used, Free infos
sub _dotDefaultFullLabel {
    my $self = shift;

    return ($self->dotLabel(@_));
}

# will be overrided for HTML
sub _dotDefaultLabelLine {
    my $self = shift;
    my @label = $self->dotFormatedFullLabel(@_);
    confess "Multiline formated label!" if scalar(@label) > 1;
    return 'label="";' if scalar(@label) == 0;

    return ('label="'.$label[0].'";');
}

# will be overrided when another node kind is selected
sub _dotDefaultNode {
    my $self = shift;
    my $t = shift // "\t";

    #print STDERR "coucou2 from ".$self->name."\n";
    my @text = (
        "{ ".$self->linkname.' [',
        $self->dotIndent(
            $t,
            $self->_dotDefaultLabelLine($t, @_),
            $self->dotStyleNode(),
        ),
        ']; }',
        );
    return @text;
}

1;

##################################################################
package StorageDisplay::Role::Style::Base::HTML;

use Moose::Role;

around '_dotLabelNL' => sub {
    my $orig = shift;
    my $self = shift;
    return '<BR/>';
};

around '_dotDefaultLabelLine' => sub {
    my $orig = shift;
    my $self = shift;
    my $t = shift;

    my @text=$self->dotIndent($t, $self->_dotTableLabel($t, @_));

    if (scalar(@text) == 0) {
        return ('label=<>;')
    }

    $text[0] =~ s/^\s+//;
    $text[0] = 'label=<'.$text[0];
    push @text, '>;';

    return @text;
};

1;

##################################################################
package StorageDisplay::Role::Style::IsLabel;

use Moose::Role;

with (
    'StorageDisplay::Role::Style::Base',
    );

around '_dotDefaultNode' => sub {
    my $orig = shift;
    my $self = shift;

    #print STDERR "coucou from ".$self->name."\n";
    return $self->_dotTableLabel(@_);
};

1;

##################################################################
package StorageDisplay::Role::Style::IsSubGraph;

use Moose::Role;

sub dotSubGraph {
    my $self = shift;
    return $self->_dotDefaultSubGraph(@_);
}

sub _dotDefaultSubGraph {
    my $self = shift;
    my $t = shift;

    my @text;
    my $it = $self->iterator(recurse => 0);
    while (defined(my $e = $it->next)) {
        push @text, $e->dotNode($t, @_);
    }
    return @text;
}

around '_dotDefaultNode' => sub {
    my $orig = shift;
    my $self = shift;
    my $t = shift // "\t";

    my @text = (
        'subgraph "cluster_'.$self->rawlinkname.'" {',
        $self->dotIndent(
            $t,
            $self->dotStyle($t, @_),
            $self->dotSubGraph($t, @_),
            $self->_dotDefaultLabelLine($t, @_),
            $self->dotStyleNode(),
        ),
        '}',
        );
    return @text;
};

around '_dotDefaultStyleNode' => sub {
    my $orig = shift;
    my $self = shift;

    return ();
};

with (
    'StorageDisplay::Role::Style::Base',
    );

1;

##################################################################
package StorageDisplay::Role::Style::Label::HTML;

use Moose::Role;

with (
    'StorageDisplay::Role::Style::Base::HTML',
    'StorageDisplay::Role::Style::Base',
    );

1;

##################################################################
package StorageDisplay::Role::Style::Label::HTML::Table;

use Moose::Role;

sub dotStyleTable {
    return '';
};

around '_dotTableLabel' => sub {
    my $orig = shift;
    my $self = shift;
    my $t = shift;
    my $it = $self->iterator(recurse => 0);

    return ('<TABLE '.$self->dotStyleTable(@_).'>',
            $self->dotIndent(
                $t,
                $self->dotTable($t, $it, @_),
            ),
            '</TABLE>',
        );
};

sub dotTable {
    my $self=shift;

    return $self->_dotDefaultTable(@_);
}

sub _dotDefaultTable {
    my $self=shift;
    my $t = shift;
    my $it = shift;

    my @text;
    while (defined(my $e = $it->next)) {
        push @text, '<TR><TD>',
            $self->dotIndent($t, $e->dotNode($t, @_)),
            '</TD></TR>'
    }

    return @text;
}

with (
    'StorageDisplay::Role::Style::Base::HTML',
    'StorageDisplay::Role::Style::Base',
    );

1;

##################################################################
package StorageDisplay::Role::Style::Plain;

use Moose::Role;

sub dotStyle {
    my $orig  = shift;
    my $self = shift;

    return ( );
};

with (
    'StorageDisplay::Role::Style::Base',
    );

1;

##################################################################
package StorageDisplay::Role::Style::WithSize;

use Moose::Role;

has 'size' => (
    is       => 'ro',
    isa      => 'Int',
    required => 1,
    );

sub dotStyle {
    my $orig  = shift;
    my $self = shift;

    return (
        "style=filled;",
        "color=lightgrey;",
        "fillcolor=lightgrey;",
        "node [style=filled,color=lightgrey,fillcolor=lightgrey,shape=rectangle];",
        );
};

sub sizeLabel {
    my $self = shift;
    return ("Size: ".$self->disp_size($self->size));
}

around '_dotDefaultFullLabel' => sub {
    my $orig  = shift;
    my $self = shift;

    return (
        $self->$orig(@_),
	$self->sizeLabel(),
        );
};

with (
    'StorageDisplay::Role::Style::Base',
    );

1;

##################################################################
package StorageDisplay::Role::Style::WithFree;

use Moose::Role;

with 'StorageDisplay::Role::Style::WithSize';

has 'free' => (
    is       => 'ro',
    isa      => 'Int',
    required => 1,
    );

around _dotDefaultStyleNode => sub {
    my $orig  = shift;
    my $self = shift;

    my $fillcolor='"green"';
    if ($self->size != $self->free) {
        $fillcolor=
            '"pink;'.
                       sprintf("%f.2", ($self->size - $self->free) / $self->size).
                       ':green"';
    }

    return $self->dotJoinStyle(
        $self->$orig(@_),
        'shape=rectangle',
        'style=striped',
        'fillcolor='.$fillcolor,
        );
};

around '_dotDefaultFullLabel' => sub {
    my $orig  = shift;
    my $self = shift;

    return (
        $self->$orig(@_),
        "Free: ".$self->disp_size($self->free),
        );
};

1;

##################################################################
package StorageDisplay::Role::Style::WithUsed;

use Moose::Role;

with 'StorageDisplay::Role::Style::WithFree';

has 'used' => (
    is       => 'ro',
    isa      => 'Int',
    required => 1,
    );

sub dotStyle {
    my $orig  = shift;
    my $self = shift;

    return (
        "style=filled;",
        "color=lightgrey;",
        "fillcolor=lightgrey;",
        "node [style=filled,color=lightgrey,fillcolor=lightgrey,shape=rectangle];",
        );
};

around '_dotDefaultFullLabel' => sub {
    my $orig  = shift;
    my $self = shift;

    my $label = $self->$orig(@_);
    return (
        $self->$orig(@_),
        "Used: ".$self->disp_size($self->used),
        );
};

1;

##################################################################
package StorageDisplay::Role::Style::SubInternal;

use Moose::Role;

sub dotStyle {
    my $self = shift;
    my $t = shift // "\t";

    return (
		#"style=filled;",
		"color=white;",
		"fillcolor=white;",
		#"node [style=filled,color=lightgrey,fillcolor=lightgrey,shape=rectangle];",
        );
}

with (
    'StorageDisplay::Role::Style::Base',
    );

1;

##################################################################
package StorageDisplay::Role::Style::Grey;

use Moose::Role;

sub dotStyle {
    my $self = shift;
    my $t = shift // "\t";

    return (
        "style=filled;",
        "color=lightgrey;",
        "fillcolor=lightgrey;",
        "node [style=filled,color=white,fillcolor=lightgrey,shape=rectangle];",
        );
}

with (
    'StorageDisplay::Role::Style::Base',
    );

1;

##################################################################
package StorageDisplay::Role::Style::Machine;

use Moose::Role;

sub dotStyle {
    my $self = shift;
    my $t = shift // "\t";

    return (
        "style=filled;",
        "color=lightgrey;",
        "fillcolor=white;",
        "node [style=filled,color=white,fillcolor=white,shape=rectangle];",
        );
}

with (
    'StorageDisplay::Role::Style::Base',
    );

1;

##################################################################
package StorageDisplay::Role::Style::FromBlockState;

use Moose::Role;

sub _dotDefaultStyleNodeState {
    my $self = shift;

    my $state = "unknown";
    if (defined($self->block)) {
        $state = $self->block->state;
    }

    return 'fillcolor="'.$self->statecolor($state).'"';
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

StorageDisplay::Role - Load all roles used in StorageDisplay

=head1 VERSION

version 2.01

=head1 AUTHOR

Vincent Danjean <Vincent.Danjean@ens-lyon.org>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2014-2023 by Vincent Danjean.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut