new Op::Predicate

diff --git a/lib/DX/Op/Predicate.pm b/lib/DX/Op/Predicate.pm
new file mode 100644 (file)
index 0000000..6971199
--- /dev/null
+++ b/lib/DX/Op/Predicate.pm
@@ -0,0 +1,43 @@
+package DX::Op::Predicate;
+
+use List::Util qw(reduce);
+use Moo;
+
+has arg_names => (is => 'ro', required => 1);
+has arg_cases => (is => 'ro', required => 1);
+
+with 'DX::Role::Op::WithArgs';
+
+sub run {
+  my ($self, $state) = @_;
+  my @args = @{$self->args};
+  my @arg_names = @{$self->arg_names};
+  my @cases = @{$self->arg_cases};
+  CASE: while (my ($req, $code) = splice @cases, 0, 2) {
+    local %_;
+    my %map;
+    my @was_bound;
+    foreach my $i (0..$#arg_names) {
+      if ($req->[$i] eq '+') {
+        next CASE unless $args[$i]->is_bound;
+        $_{$arg_names[$i]} = $args[$i]->bound_value;
+      } elsif ($req->[$i] eq '-') {
+        next CASE if $args[$i]->is_bound;
+      }
+      $map{$arg_names[$i]} = $args[$i]->id;
+      push @was_bound, $args[$i]->id if $args[$i]->is_bound;
+    }
+    my %effect = $code->();
+    my @is_bound = (@was_bound, map $map{$_}, sort keys %effect);
+    my @deps = map {
+      my $is = $_;
+      map +($is => $_), grep $is ne $_, @was_bound
+    } @is_bound;
+    return reduce {
+      $a->${\('bind_'.$effect{$b}[0])}($map{$b}, $effect{$b}[1]);
+    } $state->pop_return_stack->add_dependencies(@deps), sort keys %effect;
+  }
+  die "Arguments insufficiently bound";
+}
+
+1;

diff --git a/lib/DX/RuleSet.pm b/lib/DX/RuleSet.pm
index 09a2ff5..bc8167f 100644 (file)
--- a/lib/DX/RuleSet.pm
+++ b/lib/DX/RuleSet.pm
@@ -14,10 +14,19 @@ use DX::Op::ProposeAction;
 use DX::Op::Materialize;
 use DX::Op::Prop;
 use DX::Op::Exists;
+use DX::Op::Predicate;
 use List::Util qw(reduce);
 
 has rules => (is => 'ro', default => sub { {} });
 
+sub add_predicate {
+  my ($self, $name, $vars, @cases) = @_;
+  my $full_name = join('/', $name, scalar @$vars);
+  push @{$self->rules->{$full_name}}, DX::Op::Predicate->new(
+    arg_names => $vars, arg_cases => \@cases
+  );
+}
+
 sub add_rule {
   my ($self, $name, $vars, @body) = @_;
   my $full_name = join('/', $name, scalar @$vars);

diff --git a/lib/DX/Solver.pm b/lib/DX/Solver.pm
index 2042a10..0f23c54 100644 (file)
--- a/lib/DX/Solver.pm
+++ b/lib/DX/Solver.pm
@@ -6,9 +6,13 @@ use DX::ResultStream;
 use List::Util qw(reduce);
 use Moo;
 
-has rule_set => (is => 'lazy', handles => [ 'add_rule' ], builder => sub {
-  DX::RuleSet->new
-});
+has rule_set => (
+  is => 'lazy',
+  handles => [ qw(add_predicate add_rule) ],
+  builder => sub {
+    DX::RuleSet->new
+  },
+);
 
 has facts => (is => 'ro', required => 1);
 

diff --git a/t/dot_ssh.t b/t/dot_ssh.t
index 2e37b31..f4cb2de 100644 (file)
--- a/t/dot_ssh.t
+++ b/t/dot_ssh.t
@@ -274,25 +274,14 @@ is($path_status{'.ssh'}, $protos{'.ssh'}, 'Created observed');
 
 ok(!$res[0]->actions, 'No action');
 
+$solver->add_predicate(
+  catfile => [ qw(DirPath FileName FilePath) ],
+    [ qw(+ + -) ] => sub {
+      +(FilePath => [ value => File::Spec->catfile($_{DirPath}, $_{FileName}) ])
+    },
+);
+
 $solver->add_rule(@$_) for (
-  [ catfile => [ qw(DirPath FileName FilePath) ],
-    DX::Op::FromCode->new(code => sub {
-      my ($self, $state) = @_;
-      my ($dir_path, $file_name, $file_path)
-        = map $state->scope_var($_), qw(DirPath FileName FilePath);
-      die "No." unless $dir_path->is_bound;
-      die "No." unless $file_name->is_bound;
-      die "No." if $file_path->is_bound;
-      my $cat_file = File::Spec->catfile(
-        map $_->bound_value, $dir_path, $file_name
-      );
-      $state->bind_value($file_path->id, $cat_file)
-            ->add_dependencies(
-                $file_path->id => $dir_path->id,
-                $file_path->id => $file_name->id,
-              )
-            ->then($self->next);
-    }) ],
   [ file_in => [ qw(DirStatus FileName FileStatus) ],
     [ is_directory => qw(DirStatus) ],
     [ exists => [ qw(DirPath) ],