Reaction::UI::ViewPort::Object - Display an InterfaceModel::Object

  use aliased 'Reaction::UI::ViewPort::Object';

  ...
  $controller->push_viewport(Object,
    model           => $person_interface_model_object,
    fields_order    => [qw( firstname lastname )],
    excluded_fields => [qw( password )],
  );

  $self->_build_simple_field(
    attribute => $attribute_object,
    class     => $field_class,
    %field_attrs,
  );

package Reaction::UI::ViewPort::Object;

use Reaction::Class;

use aliased 'Reaction::UI::ViewPort::Field::Text';
use aliased 'Reaction::UI::ViewPort::Field::Number';
use aliased 'Reaction::UI::ViewPort::Field::Integer';
use aliased 'Reaction::UI::ViewPort::Field::Boolean';
use aliased 'Reaction::UI::ViewPort::Field::String';
use aliased 'Reaction::UI::ViewPort::Field::DateTime';
use aliased 'Reaction::UI::ViewPort::Field::RelatedObject';
use aliased 'Reaction::UI::ViewPort::Field::Array';
use aliased 'Reaction::UI::ViewPort::Field::Collection';
use aliased 'Reaction::UI::ViewPort::Field::File';
use aliased 'Reaction::UI::ViewPort::Field::Container';

use aliased 'Reaction::InterfaceModel::Object' => 'IM_Object';

use MooseX::Types::Moose qw/ArrayRef HashRef/;

use namespace::clean -except => [ qw(meta) ];
extends 'Reaction::UI::ViewPort';

with 'Reaction::UI::ViewPort::Role::Actions';

#everything is read only right now. Later I can make somethings read-write
#but first I need to figure out what depends on what so we can have decent triggers
has model  => (is => 'ro', isa => IM_Object, required => 1);
has fields => (is => 'ro', isa => ArrayRef, lazy_build => 1);

has field_args    => (is => 'rw');
has field_order   => (is => 'ro', isa => ArrayRef);

has builder_cache   => (is => 'ro', isa => HashRef,  lazy_build => 1);
has excluded_fields => (is => 'ro', isa => ArrayRef, lazy_build => 1);
has included_fields => (is => 'ro', isa => ArrayRef, lazy_build => 1);
has computed_field_order => (is => 'ro', isa => ArrayRef, lazy_build => 1);

has containers => ( is => 'ro', isa => ArrayRef, lazy_build => 1);
has container_layouts => ( is => 'rw', isa => ArrayRef );

sub BUILD {
  my ($self, $args) = @_;
  if( my $field_args = delete $args->{Field} ){
    $self->field_args( $field_args );
  }
}

sub _build_builder_cache { {} }
sub _build_excluded_fields { [] }
sub _build_included_fields { [] }

sub _build_containers {
  my $self = shift;

  my @container_layouts;
  if( $self->has_container_layouts ){
    #make sure we don't accidentally modify the original
    @container_layouts = map { {%$_} }@{ $self->container_layouts };
  } #we should always have a '_' container;
  unless (grep {$_->{name} eq '_'} @container_layouts ){
    unshift(@container_layouts, {name => '_'});
  }

  my %fields;
  my $ordered_field_names = $self->computed_field_order;
  @fields{ @$ordered_field_names } = @{ $self->fields };

  my %containers;
  my @container_order;
  for my $layout ( @container_layouts ){
    my @container_fields;
    my $name = $layout->{name};
    push(@container_order, $name);
    if( my $field_names = delete $layout->{fields} ){
      map{ push(@container_fields, $_) } grep { defined }
        map { delete $fields{$_} } @$field_names;
    }
    $containers{$name} = Container->new(
      ctx => $self->ctx,
      location => join( '-', $self->location, 'container', $name ),
      fields => \@container_fields,
      %$layout,
    );
  }
  if( keys %fields ){
    my @leftovers = grep { exists $fields{$_} } @$ordered_field_names;
    push(@{ $containers{_}->fields }, @fields{@leftovers} );
  }

  #only return containers with at least one field
  return [ grep { scalar(@{ $_->fields }) } @containers{@container_order} ];
}

sub _build_fields {
  my ($self) = @_;
  my $obj  = $self->model;
  my $args = $self->has_field_args ? $self->field_args : {};
  my @fields;
  my %param_attrs = map { $_->name => $_ } $obj->parameter_attributes;
  for my $field_name (@{ $self->computed_field_order }) {
    my $attr = $param_attrs{$field_name};
    my $meth = $self->builder_cache->{$field_name} ||= $self->get_builder_for($attr);
    my $field = $self->$meth($attr, ($args->{$field_name} || {}));
    next unless $field;
    push(@fields, $field);
  }
  return \@fields;
}

sub _build_computed_field_order {
  my ($self) = @_;
  my %excluded = map { $_ => undef } @{ $self->excluded_fields };
  my %included = map { $_ => undef } @{ $self->included_fields };
  #treat _$field_name as private and exclude fields with no reader
  my @names = grep { $_ !~ /^_/ && (!%included || exists( $included{$_}) )
    && !exists($excluded{$_}) } map { $_->name }
    grep { defined $_->get_read_method } $self->model->parameter_attributes;
  return $self->sort_by_spec($self->field_order || [], \@names);
}

override child_event_sinks => sub {
  return ( @{shift->fields}, super());
};

#candidate for shared role!
sub get_builder_for {
  my ($self, $attr) = @_;
  my $attr_name = $attr->name;
  my $builder = "_build_fields_for_name_${attr_name}";
  return $builder if $self->can($builder);
  if ($attr->has_type_constraint) {
    my $constraint = $attr->type_constraint;
    my $base_name = $constraint->name;
    my $tried_isa = 0;
    my @tried;
  CONSTRAINT: while (defined($constraint)) {
      my $name = $constraint->name;
      $name = $attr->_isa_metadata if($name eq '__ANON__');
      if (eval { $name->can('meta') } && !$tried_isa++) {
        foreach my $class ($name->meta->class_precedence_list) {
          push(@tried, $class);
          my $mangled_name = $class;
          $mangled_name =~ s/:+/_/g;
          my $builder = "_build_fields_for_type_${mangled_name}";
          return $builder if $self->can($builder);
        }
      }
      if (defined($name)) {
        push(@tried, $name);
        unless (defined($base_name)) {
          $base_name = "(anon subtype of ${name})";
        }
        my $mangled_name = $name;
        $mangled_name =~ s/:+/_/g;
        my $builder = "_build_fields_for_type_${mangled_name}";
        return $builder if $self->can($builder);
      }
      $constraint = $constraint->parent;
    }
    if (!defined($constraint)) {
      confess "Can't build field ${attr_name} of type ${base_name} without "
              ."$builder method or _build_fields_for_type_<type> method "
              ."for type or any supertype (tried ".join(', ', @tried).")";
    }
  } else {
    confess "Can't build field ${attr} without $builder method or type constraint";
  }
}

sub _build_simple_field {
  my ($self, %args) = @_;
  my $class = delete $args{class};
  confess("Can not build simple field without a viewport class")
    unless $class;
  confess("Can not build simple field without attribute")
    unless defined $args{attribute};

  my $field_name = $args{attribute}->name;
  return $class->new(
    ctx => $self->ctx,
    model => $self->model,
    location => join('-', $self->location, 'field', $field_name),
    %args
  );
}

sub _build_fields_for_type_Num {
  my ($self, $attr, $args) = @_;
  $self->_build_simple_field(attribute => $attr, class => Number, %$args);
}

sub _build_fields_for_type_Int {
  my ($self, $attr, $args) = @_;
  #XXX
  $self->_build_simple_field(attribute => $attr, class => Integer, %$args);
}

sub _build_fields_for_type_Bool {
  my ($self,  $attr, $args) = @_;
  $self->_build_simple_field(attribute => $attr, class => Boolean, %$args);
}

#XXX
sub _build_fields_for_type_Reaction_Types_Core_Password { return };

sub _build_fields_for_type_Str {
  my ($self, $attr, $args) = @_;
  #XXX
  $self->_build_simple_field(attribute => $attr, class => String, %$args);
}

sub _build_fields_for_type_Reaction_Types_Core_SimpleStr {
  my ($self, $attr, $args) = @_;
  $self->_build_simple_field(attribute => $attr, class => String, %$args);
}

sub _build_fields_for_type_Reaction_Types_DateTime_DateTime {
  my ($self, $attr, $args) = @_;
  $self->_build_simple_field(attribute => $attr, class => DateTime, %$args);
}

sub _build_fields_for_type_Enum {
  my ($self, $attr, $args) = @_;
  #XXX
  $self->_build_simple_field(attribute => $attr, class => String, %$args);
}

sub _build_fields_for_type_ArrayRef {
  my ($self, $attr, $args) = @_;
  $self->_build_simple_field(attribute => $attr, class => Array, %$args);
}

sub _build_fields_for_type_Reaction_Types_File_File {
  my ($self, $attr, $args) = @_;
  $self->_build_simple_field(attribute => $attr, class => File, %$args);
}

sub _build_fields_for_type_Reaction_InterfaceModel_Object {
  my ($self, $attr, $args) = @_;
  #XXX
  $self->_build_simple_field(attribute => $attr, class => RelatedObject, %$args);
}

sub _build_fields_for_type_Reaction_InterfaceModel_Collection {
  my ($self, $attr, $args) = @_;
  $self->_build_simple_field(attribute => $attr, class => Collection, %$args);
}

sub _build_fields_for_type_MooseX_Types_Common_String_SimpleStr {
  my ($self, $attr, $args) = @_;
  $self->_build_simple_field(attribute => $attr, class => String, %$args);
}

sub _build_fields_for_type_MooseX_Types_Common_String_Password {
  return;
}

sub _build_fields_for_type_MooseX_Types_DateTime_DateTime {
  my ($self, $attr, $args) = @_;
  $self->_build_simple_field(attribute => $attr, class => DateTime, %$args);
}

sub _build_fields_for_type_DateTime {
  my ($self, $attr, $args) = @_;
  $self->_build_simple_field(attribute => $attr, class => DateTime, %$args);
}

__PACKAGE__->meta->make_immutable;

1;

__END__;