rspace tracing

[scpubgit/DX.git] / lib / DX / ResolutionStrategy.pm

package DX::ResolutionStrategy;

use DX::Resolution;
use DX::Class;

has action_prototypes => (is => 'ro', required => 1);

has veracity_depends_on_builder => (is => 'ro', required => 1);

has implementation_candidates => (is => 'ro', required => 1);

has aperture => (is => 'lazy', builder => sub {
  my ($self) = @_;
  return [
    # [ $thing, 'set_value' ] -> $thing->aperture_for_set_value
    map @{$_->[0]->${\'aperture_for_'.$_[1]}()},
      @{$self->action_prototypes}
  ];
});

sub next_resolution {
  my ($self) = @_;
  return undef unless my ($first) = @{$self->implementation_candidates};
  my @ap = @{$self->action_prototypes};
  my @cand = @$first;
  return DX::Resolution->new(
    actions => [
      map {
        my ($inv, $type, @args) = @{$ap[$_]};
        $inv->${\"action_for_${type}"}(@args, @{$cand[$_]});
      } 0..$#ap
    ],
    veracity_depends_on => $self->veracity_depends_on_builder->(@cand),
  );
}

sub remainder {
  my ($self) = @_;
  my ($first, @rest) = @{$self->implementation_candidates};
  return () unless @rest;
  return $self->but(implementation_candidates => \@rest);
}

sub for_deparse {
  my ($self) = @_;
  [ statement => [
    [ symbol => 'resolution_strategy' ],
    [ pairs => [
      [ action_prototypes => [ block => [
        map {
          my ($inv, $type, @args) = @$_;
          [ statement => [
            [ symbol => $type ],
            [ value_path => $inv->value_path ],
            @args
          ] ]
        } @{$self->action_prototypes}
      ] ] ],
      [ implementation_candidates => [ block => [
        map [ block => [
          map [ block => [
            map +($_->value_path ? [ value_path => $_->value_path ] : $_), @$_
          ] ], @$_
        ] ], @{$self->implementation_candidates}
      ] ] ]
    ] ],
  ] ];
}

1;