lib/DX/Predicate/MemberAt.pm

   1 package DX::Predicate::MemberAt;
   2
   3 use DX::Utils qw(step INDICES_OF EXISTENCE_OF CONTENTS_OF string);
   4 use DX::ActionBuilder::ProxySetToAdd;
   5 use DX::ActionBuilder::Null;
   6 use DX::Class;
   7
   8 with 'DX::Role::Predicate';
   9
  10 sub _possible_resolution_list {
  11   my ($self, $coll, $key, $value) = @_;
  12   die "First argument to member_at must be a structured value"
  13     unless $coll->does('DX::Role::StructuredValue');
  14   my $basic_deps = sub {
  15     (depends_on => [
  16       [ undef ,=>
  17         [ EXISTENCE_OF ,=> $coll, ($_[1]||$_[0])->string_value ],
  18         [ CONTENTS_OF ,=> $_[0] ],
  19       ],
  20       [ $value ,=>
  21         [ CONTENTS_OF ,=> $coll, ($_[1]||$_[0])->string_value ],
  22         [ CONTENTS_OF ,=> $value ],
  23       ],
  24     ])
  25   };
  26   if ($value->is_set) {
  27     # Already set values are only supported for recheck
  28     trace member_at => "+D +K +V";
  29     return () unless $key->is_set and my $cur_val = $coll->get_member_at($key);
  30     return () unless $cur_val->equals($value);
  31     return step(
  32       actions => [],
  33       $basic_deps->($key),
  34     );
  35   }
  36   die "Bizarre: member_at called with non-fresh unset value"
  37     unless $value->action_builder->isa('DX::ActionBuilder::UnsetValue');
  38   if ($key->is_set) {
  39     trace member_at => "+D +K -V";
  40     if (my $cur_val = $coll->get_member_at($key)) {
  41       my $set = $value->action_for_set_value($cur_val);
  42       return step(
  43         actions => [ $set ],
  44         $basic_deps->($key),
  45       );
  46     }
  47     if (my $p = $coll->value_path) {
  48       my @path = (@$p, $key->string_value);
  49       my $ab = DX::ActionBuilder::ProxySetToAdd->new(
  50         target_path => \@path,
  51         proxy_to => $coll->action_builder,
  52       );
  53       my $set = $value->action_for_set_value(
  54                   $value->but(
  55                     action_builder => $ab
  56                   )
  57                 );
  58       return step(
  59         actions => [ $set ],
  60         $basic_deps->($key),
  61       );
  62     }
  63     return ();
  64   }
  65   die "Bizarre: member_at called with non-fresh unset key"
  66     unless $key->action_builder->isa('DX::ActionBuilder::UnsetValue');
  67   trace member_at => "+D -K -V";
  68   return map {
  69            my $set_key = $key->action_for_set_value(my $kstr = string($_));
  70            my $set_value = $value->action_for_set_value($coll->get_member_at($kstr));
  71            step(
  72              actions => [ $set_key, $set_value ],
  73              $basic_deps->($key, $kstr),
  74            );
  75          } $coll->index_list;
  76 }
  77
  78 sub selection_depends_on {
  79   my ($self, $coll, $key, $value) = @_;
  80   die "NEEDS REDOING";
  81   [ [ $coll => ($key->can_set_value ? INDICES_OF : (EXISTENCE_OF ,=> $key)) ],
  82     $key,
  83     $value,
  84   ]
  85 }
  86
  87 1;