pass rspace to backtrack (as yet unused), tweak DependencyMap API

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

package DX::DependencyMap;

use DX::Utils qw(CONTENTS_OF INDICES_OF);
use DX::Class;

# { x => [ { y => [ ...
# my $targ = $root; $targ = $targ->[0]{$_[0]} for @path
# my $deps = $targ->[$${$dep_type}];

has deps => (is => 'ro', isa => DependencyTree, required => 1);

has revdeps => (is => 'ro', required => 1, isa => HashRef[DependencyList]);

sub new_empty {
  my ($class) = @_;
  $class->new(deps => {}, revdeps => {});
}

sub with_dependencies_for {
  my ($self, $for_id, $deps_for) = @_;
  my $old_revdeps = $self->revdeps;
  my $new_revdeps = {
    %{$old_revdeps},
    $for_id => [ @{$old_revdeps->{$for_id}||[]}, @$deps_for ],
  };
  my $new_deps = $self->_merge_deps_for(
    $self->deps, $for_id, @$deps_for
  );
  ref($self)->new(
    deps => $new_deps,
    revdeps => $new_revdeps
  );
}

sub without_entries_for {
  my ($self, @for_ids) = @_;
  my %new_revdeps = %{$self->revdeps};
  my $new_deps = $self->deps;
  $new_deps = $self->_unmerge_deps_for(
    $new_deps, $_, @{$new_revdeps{$_}}
  ) for @for_ids;
  delete @new_revdeps{@for_ids};
  ref($self)->new(
    deps => $new_deps,
    revdeps => \%new_revdeps
  );
}

sub _merge_deps_for {
  my ($self, $deps, $for_id, @merge_these) = @_;
  $self->_mangle_deps($deps, sub {
    +{ %{$_[0]}, $for_id => 1 };
  }, @merge_these);
}

sub _unmerge_deps_for {
  my ($self, $deps, $for_id, @unmerge_these) = @_;
  $self->_mangle_deps($deps, sub {
    my %for_ids = %{$_[0]};
    delete $for_ids{$for_id};
    \%for_ids;
  }, @unmerge_these);
}

sub _mangle_deps {
  my ($self, $deps, $mangler, @to_mangle) = @_;
  my $root = [ $deps ];
  foreach my $mangle_this (@to_mangle) {
    assert_DependencySpec $mangle_this;
    my ($type, @path) = @$mangle_this;
    my $targ = $root;
    foreach my $part (@path) {
      my $sub = $targ->[0] = { %{$targ->[0]||{}} };
      $targ = $sub->{$part} = [ @{$sub->{$part}||[]} ];
    }
    $targ->[$$$type] = $mangler->($targ->[$$$type]||{});
  }
  return $root->[0];
}

sub dependents_of {
  my ($self, $event) = @_;
  my ($type, @path) = @$event;
  my $root = [ $self->deps ];
  my $targ = $root;
  my $last = pop @path;
  my @dep_sets;
  foreach my $part (@path) {
    $targ = $targ->[0]{$part};
    # set/add/remove x.y or x.y.z affects contents of x
    push @dep_sets, $targ->[$${+CONTENTS_OF}];
  }
  if ($$$type) {
    # add/remove x.y affects indices of x
    push @dep_sets, $targ->[$${+INDICES_OF}];
  }
  $targ = $targ->[0]{$last};
  {
    # add/remove x affects existence of x
    # set/add/remove x affects everything else too
    push @dep_sets, @{$targ}[map $$$_, @$$type];
  }
  # set/add/remove x affects all dependencies on x.y, x.y.z etc.
  my @q = values %{$targ->[0]};
  while (my $el = shift @q) {
    my ($el_kids, @el_deps) = @$el;
    push @dep_sets, @el_deps;
    push @q, values %{$el_kids||{}};
  }
  return keys %{{
    map +($_ => 1), map keys %$_, grep defined, @dep_sets
  }};
}

sub but_expire_dependents_of {
  my ($self, @events) = @_;
  my @expired = keys %{{
    map +($_ => 1), map $self->dependents_of($_), @events
  }};
  # Didn't expire anything? Don't clone self
  return $self unless @expired;
  ($self->without_entries_for(@expired), @expired);
}

sub dependencies_for { $_[0]->revdeps->{$_[1]} }

1;