lib/DX/Predicate/MemberAt.pm

   1 package DX::Predicate::MemberAt;
   2
   3 use DX::Utils qw(step INDICES_OF EXISTENCE_OF CONTENTS_OF);
   4 use DX::Class;
   5
   6 with 'DX::Role::Predicate';
   7
   8 # Thing I've ignored for the moment: set key, unset value
   9 # which for an add should result in an _make_equal style
  10 # bind-with-add-action I suspect, but I don't have a current use
  11 # case so punting while I get everything-the-fuck-else done
  12
  13 sub _possible_resolution_list {
  14   my ($self, $coll, $key, $value) = @_;
  15   die "First argument to member_at must be a structured value"
  16     unless $coll->does('DX::Role::StructuredValue');
  17   return (
  18     ($key->is_set
  19       ? map $_->but_with_dependencies_on(
  20           [ undef ,=>
  21             [ EXISTENCE_OF ,=> $coll, $key->string_value ],
  22             [ CONTENTS_OF ,=> $key ],
  23           ]
  24         ), do {
  25           if (my $cur_val = $coll->get_member_at($key)) {
  26             $self->_make_equal($cur_val, $value);
  27           } elsif (
  28             $value->is_set
  29             and my $add = $coll->action_for_add_member($key, $value)
  30           ) {
  31             step(
  32               actions => [ $add ],
  33               depends_on => [
  34                 [ $value =>
  35                   [ CONTENTS_OF ,=> $coll, $key->string_value ],
  36                   [ CONTENTS_OF ,=> $value ],
  37                 ],
  38               ],
  39             );
  40           } else {
  41             ()
  42           }
  43         }
  44       : ()
  45     ),
  46     ($key->can_set_value
  47       ? map {
  48           my $set_key = $key->action_for_set_value($_);
  49           map $_->but_first($set_key)
  50                 ->but_with_dependencies_on(
  51                     [ undef ,=>
  52                       [ EXISTENCE_OF ,=> $coll, $key->string_value ]
  53                     ]
  54                   ),
  55             $self->_make_equal($coll->get_member_at($_), $value);
  56         } $coll->index_list
  57       : ()
  58     ),
  59   );
  60 }
  61
  62 sub selection_depends_on {
  63   my ($self, $coll, $key, $value) = @_;
  64   die "NEEDS REDOING";
  65   [ [ $coll => ($key->can_set_value ? INDICES_OF : (EXISTENCE_OF ,=> $key)) ],
  66     $key,
  67     $value,
  68   ]
  69 }
  70
  71 1;