first cut of rspace/rstrat code with eq semi cut over

[scpubgit/DX.git] / lib / DX / Predicate / MemberAt.pm

package DX::Predicate::MemberAt;

use DX::Utils qw(:builders :dep_types);
use DX::ActionBuilder::ProxySetToAdd;
use DX::ActionBuilder::Null;
use DX::Class;

with 'DX::Role::Predicate';

sub _possible_resolution_list {
  my ($self, $coll, $key, $value) = @_;
  die "First argument to member_at must be a structured value"
    unless $coll->does('DX::Role::StructuredValue');
  my $basic_deps = sub {
    (depends_on => [
      [ EXISTENCE_OF ,=> $coll, ($_[1]||$_[0])->string_value ],
      [ CONTENTS_OF ,=> $_[0] ],
      [ CONTENTS_OF ,=> $coll, ($_[1]||$_[0])->string_value ],
      [ CONTENTS_OF ,=> $value ],
    ])
  };
  if ($value->is_set) {
    # Already set values are only supported for recheck
    trace member_at => "+D +K +V";
    return () unless $key->is_set and my $cur_val = $coll->get_member_at($key);
    return () unless $cur_val->equals($value);
    return step(
      actions => [],
      $basic_deps->($key),
    );
  }
  die "Bizarre: member_at called with non-fresh unset value"
    unless $value->action_builder->isa('DX::ActionBuilder::UnsetValue');
  if ($key->is_set) { 
    trace member_at => "+D +K -V";
    if (my $cur_val = $coll->get_member_at($key)) {
      my $set = $value->action_for_set_value($cur_val);
      return step(
        actions => [ $set ],
        $basic_deps->($key),
      );
    }
    if (my $p = $coll->value_path) {
      my @path = (@$p, $key->string_value);
      my $ab = DX::ActionBuilder::ProxySetToAdd->new(
        target_path => \@path,
        proxy_to => $coll->action_builder,
      );
      my $set = $value->action_for_set_value(
                  $value->but(
                    action_builder => $ab
                  )
                );
      return step(
        actions => [ $set ],
        $basic_deps->($key),
      );
    }
    return ();
  }
  die "Bizarre: member_at called with non-fresh unset key"
    unless $key->action_builder->isa('DX::ActionBuilder::UnsetValue');
  trace member_at => "+D -K -V";
  return map {
           my $set_key = $key->action_for_set_value(my $kstr = string($_));
           my $set_value = $value->action_for_set_value($coll->get_member_at($kstr));
           step(
             actions => [ $set_key, $set_value ],
             $basic_deps->($key, $kstr),
           );
         } $coll->index_list;
}

sub selection_depends_on {
  my ($self, $coll, $key, $value) = @_;
  die "NEEDS REDOING";
  [ [ $coll => ($key->can_set_value ? INDICES_OF : (EXISTENCE_OF ,=> $key)) ],
    $key,
    $value,
  ]
}

# member_at Dict Key Value
#
# Dict must be set to a dict (later maybe also an array and Key -> Index)
#
# Key bound ->
#
#   Key exists ->
#
#     Value bound ->
#
#       Dict.Key = Value ->
# 
#         Trivial resolution
#
#       Dict.Key != Value ->
#
#         Failure
#
#     Value unbound ->
#
#       Set value to Dict.Key
#
#   Key does not exist ->
#
#     Dict allows add ->
#
#       Value bound ->
#
#         Failure on (exists Dict.Key, Value)
#
#       Value unbound ->
#
#         Set value to ProxySetToAdd value
#
#     Dict disallows add ->
#
#       Failure on (exists Dict.Key)
#
# Key unbound ->
#
#   Value must also be unbound, because seriously?
#
#   Set [Key, Value] to each pair in turn

sub _resolution_space_for {
  my ($self, $dict, $key, $value) = @_;

  die "Fucked" unless $dict->does('DX::Role::StructuredValue');

  if ($key->is_set) {

    if (my $cur_val = $dict->get_member_at($key)) {

      my $deps = [
        [ CONTENTS_OF ,=> $dict, $key->string_value ],
        [ CONTENTS_OF ,=> $value ],
      ];

      if ($value->is_set) {

        my @members = (
          $cur_val->equals($value)
            # Trivial resolution, D.K = V
            ? res(
                actions => [],
                veracity_depends_on => $deps,
              )
            # Failure
            : ()
        );

        return rspace(
          geometry_depends_on => $deps,
          members => \@members
        );

      }

      return rspace(
        geometry_depends_on => [
          [ CONTENTS_OF ,=> $dict, $key->string_value ],
          [ TYPE_OF ,=> $value ],
        ],
        members => [
          res(
            actions => [ $value->action_for_set_value($cur_val) ],
            veracity_depends_on => $deps,
          ),
        ]
      );

    }

    if ($dict->can_add_member) {

      my $deps = [
        [ EXISTENCE_OF ,=> $dict, $key->string_value ],
        [ TYPE_OF ,=> $value ],
      ];

      if ($value->is_set) {

        # If we get here, it means (currently) that we entered recheck
        # due to the deletion of the key from the dict and should fail
        # (or there's a bug in the compiler but let's hope not)
        return rspace(
          geometry_depends_on => $deps,
          members => [],
        );
      }

      my @path = (@{$dict->value_path}, $key->string_value);
      my $ab = DX::ActionBuilder::ProxySetToAdd->new(
        target_path => \@path,
        proxy_to => $dict->action_builder,
      );

      return rspace(
        geometry_depends_on => $deps,
        members => [
          res(
            actions => [
              $value->action_for_set_value(
                $value->but(action_builder => $ab),
              ),
            ],
            # Veracity only depends on EXISTENCE_OF at this stage - if the
            # $value is later set, recheck will lead us down a different path
            # that will update those dependencies to include CONTENTS_OF
            veracity_depends_on => $deps,
          ),
        ],
      );

    }

    # Dict doesn't allow adding keys and key doesn't exist, so
    # the contents of the value is completely irrelevant to the failure
    return rspace(
      geometry_depends_on => [
        [ EXISTENCE_OF ,=> $dict, $key->string_value ],
      ],
      members => [],
    );

  }

  die "Fucked" if $value->is_set; # +D -K +V ? seriously ?

  # Laaater we may need to look at autovivifying an additional key/index
  # ala ProxySetToAdd but I'm not 100% sure how that will make sense and
  # premature generalisation is the root of all eval.

  my @cand = map [
    [ $_ ],
    [ $dict->get_member_at($_) ],
  ], map string($_), $dict->index_list;

  return rspace(
    geometry_depends_on => [
      [ INDICES_OF ,=> $dict ],
      [ TYPE_OF ,=> $key ],
      [ TYPE_OF ,=> $value ],
    ],
    members => [
      rstrat(
        action_prototypes => [
          [ $key => 'set_value' ],
          [ $value => 'set_value' ],
        ],
        veracity_depends_on_builder => sub {
          my ($this_key, $this_val) = @_;
          return [
            [ CONTENTS_OF ,=> $dict, $this_key->string_value ],
            [ CONTENTS_OF ,=> $key ],
            [ CONTENTS_OF ,=> $value ],
          ];
        },
        implementation_candidates => \@cand,
      ),
    ],
  );
}

1;