lib/DX/ResolutionStrategy.pm

   1 package DX::ResolutionStrategy;
   2
   3 use DX::Resolution;
   4 use DX::Class;
   5
   6 has action_prototypes => (is => 'ro', required => 1);
   7
   8 has veracity_depends_on_builder => (is => 'ro', required => 1);
   9
  10 has implementation_candidates => (is => 'ro', required => 1);
  11
  12 has aperture => (is => 'lazy', builder => sub {
  13   my ($self) = @_;
  14   return [
  15     # [ $thing, 'set_value' ] -> $thing->aperture_for_set_value
  16     map @{$_->[0]->${\'aperture_for_'.$_[1]}()},
  17       @{$self->action_prototypes}
  18   ];
  19 });
  20
  21 sub next_resolution {
  22   my ($self) = @_;
  23   return undef unless my ($first) = @{$self->implementation_candidates};
  24   my @ap = @{$self->action_prototypes};
  25   my @cand = @$first;
  26   return DX::Resolution->new(
  27     actions => [
  28       map {
  29         my ($inv, $type, @args) = @{$ap[$_]};
  30         $inv->${\"action_for_${type}"}(@args, @{$cand[$_]});
  31       } 0..$#ap
  32     ],
  33     veracity_depends_on => $self->veracity_depends_on_builder->(@cand),
  34   );
  35 }
  36
  37 sub remainder {
  38   my ($self) = @_;
  39   my ($first, @rest) = @{$self->implementation_candidates};
  40   return () unless @rest;
  41   return $self->but(implementation_candidates => \@rest);
  42 }
  43
  44 sub for_deparse {
  45   my ($self) = @_;
  46   [ word_and_body => [
  47     'resolution_strategy',
  48     [ pairs => [
  49       [ action_prototypes => [ block => [
  50         map {
  51           my ($inv, $type, @args) = @$_;
  52           [ statement => [
  53             [ symbol => $type ],
  54             [ value_path => $inv->value_path ],
  55             @args
  56           ] ]
  57         } @{$self->action_prototypes}
  58       ] ] ],
  59       [ implementation_candidates => [ list => [
  60         map [ list => [
  61           map [ list => [
  62             map +($_->value_path ? [ value_path => $_->value_path ] : $_), @$_
  63           ] ], @$_
  64         ] ], @{$self->implementation_candidates}
  65       ] ] ]
  66     ] ],
  67   ] ];
  68 }
  69
  70 1;