From: Matt S Trout <mst@shadowcat.co.uk>
Date: Mon, 3 Feb 2014 09:34:58 +0000 (+0000)
Subject: not and action infrastructure
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=71217e421021100f3b07945357bd2fdaac638c4b;p=scpubgit%2FDKit.git

not and action infrastructure
---

diff --git a/lib/DX/Action/FromCode.pm b/lib/DX/Action/FromCode.pm
new file mode 100644
index 0000000..88e8b27
--- /dev/null
+++ b/lib/DX/Action/FromCode.pm
@@ -0,0 +1,12 @@
+package DX::Action::FromCode;
+
+use Moo;
+
+has expect => (is => 'ro', required => 1);
+
+has perform => (is => 'ro', required => 1);
+
+sub expected_effect { $_[0]->expect->() }
+sub run { $_[0]->perform->() }
+
+1;
diff --git a/lib/DX/Op/Backtrack.pm b/lib/DX/Op/Backtrack.pm
new file mode 100644
index 0000000..098959f
--- /dev/null
+++ b/lib/DX/Op/Backtrack.pm
@@ -0,0 +1,9 @@
+package DX::Op::Backtrack;
+
+use Moo;
+
+with 'DX::Role::Op';
+
+sub run { $_[1]->backtrack };
+
+1;
diff --git a/lib/DX/Op/CallRule.pm b/lib/DX/Op/CallRule.pm
index e5dbb48..f3d1b4f 100644
--- a/lib/DX/Op/CallRule.pm
+++ b/lib/DX/Op/CallRule.pm
@@ -17,6 +17,7 @@ has full_name => (is => 'lazy', builder => sub {
 
 sub run {
   my ($self, $state) = @_;
+#warn "Call: ".$self->full_name;
   my @args = map $self->_expand_argspec($state, $_), @{$self->rule_args};
   my @rules = @{$state->rule_set->rules->{$self->full_name}||[]};
   die "No rules for ${\$self->full_name}" unless @rules;
diff --git a/lib/DX/Op/Materialize.pm b/lib/DX/Op/Materialize.pm
new file mode 100644
index 0000000..beb15f8
--- /dev/null
+++ b/lib/DX/Op/Materialize.pm
@@ -0,0 +1,15 @@
+package DX::Op::Materialize;
+
+use Moo;
+
+with 'DX::Role::Op';
+
+has var_name => (is => 'ro', required => 1);
+
+sub run {
+  my ($self, $state) = @_;
+  $state->scope_var($self->var_name)->bound_value;
+  $state->then($self->next);
+}
+
+1;
diff --git a/lib/DX/Op/Not.pm b/lib/DX/Op/Not.pm
new file mode 100644
index 0000000..a70183a
--- /dev/null
+++ b/lib/DX/Op/Not.pm
@@ -0,0 +1,32 @@
+package DX::Op::Not;
+
+use DX::Op::FromCode;
+use DX::Var;
+use DX::ArrayStream;
+use DX::Op::Return;
+use Moo;
+
+with 'DX::Role::Op';
+
+has body => (is => 'ro', required => 1);
+
+sub run {
+  my ($self, $state) = @_;
+  my $var = DX::Var->new(id => "rule:not")
+                   ->with_stream(DX::ArrayStream->from_array(
+                       $self->body, DX::Op::Return->new
+                     ));
+  my $invoke = DX::Op::FromCode->new(
+    code => sub {
+      my ($self, $state) = @_;
+      my $op = $var->bound_value;
+      $state->then($op);
+    }
+  );
+  my $ret_op = DX::Op::SetScope->new(
+    scope => $state->scope, next => $self->next
+  );
+  $state->push_return_then($self->next, $invoke)->mark_choice($var);
+}
+
+1;
diff --git a/lib/DX/Op/ProposeAction.pm b/lib/DX/Op/ProposeAction.pm
new file mode 100644
index 0000000..ca9c38d
--- /dev/null
+++ b/lib/DX/Op/ProposeAction.pm
@@ -0,0 +1,28 @@
+package DX::Op::ProposeAction;
+
+use DX::ObservationRequired;
+use Moo;
+
+with 'DX::Role::Op';
+
+has vars => (is => 'ro', required => 1);
+has builder => (is => 'ro', required => 1);
+
+has _arg_map => (is => 'lazy', builder => sub {
+  my ($self) = @_;
+  my $name = 'arg0';
+  +{ map +($name++, $_), @{$self->vars} };
+});
+
+sub run {
+  my ($self, $state) = @_;
+  ($state, my %args) = $self->_expand_args($state, %{$self->_arg_map});
+  my @vars = @args{sort keys %args};
+  my $action = $self->builder->(@vars);
+  my ($id, $value) = $action->expected_effect;
+  my $var = $state->by_id->{$id}->with_value($value)->with_action($action);
+  $state->but(by_id => { %{$state->by_id}, $id => $var })
+        ->then($self->next);
+}
+
+1;
diff --git a/lib/DX/ResultStream.pm b/lib/DX/ResultStream.pm
index 17f0bd7..e439ce9 100644
--- a/lib/DX/ResultStream.pm
+++ b/lib/DX/ResultStream.pm
@@ -39,7 +39,7 @@ sub next {
     return;
   }
   return +{
-    map +($_ => $state->scope_var($_)->bound_value), keys %{$state->scope}
+    map +($_ => $state->scope_var($_)->copy), keys %{$state->scope}
   };
 }
 
diff --git a/lib/DX/RuleSet.pm b/lib/DX/RuleSet.pm
index 13b6696..8840fb0 100644
--- a/lib/DX/RuleSet.pm
+++ b/lib/DX/RuleSet.pm
@@ -6,7 +6,11 @@ use DX::Op::MemberOf;
 use DX::Op::ApplyConstraint;
 use DX::Op::Return;
 use DX::Op::Cut;
+use DX::Op::Backtrack;
 use DX::Op::Observe;
+use DX::Op::Not;
+use DX::Op::ProposeAction;
+use DX::Op::Materialize;
 use List::Util qw(reduce);
 
 has rules => (is => 'ro', default => sub { {} });
@@ -20,15 +24,20 @@ sub add_rule {
 
 sub _make_rule {
   my ($self, $vars, @body) = @_;
-  my $head = reduce { $b->but(next => $a) }
-               DX::Op::Return->new,
-               reverse map $self->expand(@$_), @body;
+  my $head = $self->_expand_and_link(DX::Op::Return->new, @body);
   [ $vars, $head ];
 }
 
+sub _expand_and_link {
+  my ($self, $last, @body) = @_;
+  return reduce { $b->but(next => $a) }
+           $last,
+           reverse map $self->expand(@$_), @body;
+}
+
 sub expand {
   my ($self, $type, @rest) = @_;
-  if ($self->can(my $expand_meth = "_expand_${type}")) {
+  if ($self->can(my $expand_meth = "_expand_op_${type}")) {
     return $self->$expand_meth(@rest);
   }
   return $self->_expand_call($type, @rest);
@@ -39,9 +48,19 @@ sub _expand_call {
   DX::Op::CallRule->new(rule_name => $name, rule_args => \@args);
 }
 
-sub _expand_cut { return DX::Op::Cut->new }
+sub _expand_op_cut { return DX::Op::Cut->new }
 
-sub _expand_member_of {
+sub _expand_op_fail { return DX::Op::Backtrack->new }
+
+sub _expand_op_not {
+  my ($self, @contents) = @_;
+  my $cut = DX::Op::Cut->new(next => DX::Op::Backtrack->new);
+  DX::Op::Not->new(
+    body => $self->_expand_and_link($cut, @contents)
+  );
+}
+
+sub _expand_op_member_of {
   my ($self, $member_var, $coll_var) = @_;
   DX::Op::MemberOf->new(
     member_var => $member_var,
@@ -49,7 +68,7 @@ sub _expand_member_of {
   );
 }
 
-sub _expand_constrain {
+sub _expand_op_constrain {
   my ($self, $vars, $constraint) = @_;
   DX::Op::ApplyConstraint->new(
     vars => $vars,
@@ -57,7 +76,7 @@ sub _expand_constrain {
   );
 }
 
-sub _expand_observe {
+sub _expand_op_observe {
   my ($self, $vars, $builder) = @_;
   DX::Op::Observe->new(
     vars => $vars,
@@ -65,4 +84,17 @@ sub _expand_observe {
   );
 }
 
+sub _expand_op_act {
+  my ($self, $vars, $builder) = @_;
+  DX::Op::ProposeAction->new(
+    vars => $vars,
+    builder => $builder,
+  );
+}
+
+sub _expand_op_materialize {
+  my ($self, $var_name) = @_;
+  DX::Op::Materialize->new(var_name => $var_name);
+}
+
 1;
diff --git a/lib/DX/SetOver.pm b/lib/DX/SetOver.pm
index 74090bd..45ca5ba 100644
--- a/lib/DX/SetOver.pm
+++ b/lib/DX/SetOver.pm
@@ -25,4 +25,10 @@ sub set_value {
   return $self;
 }
 
+sub remove_value {
+  my ($self, $value) = @_;
+  delete $self->values->{$value->${\$self->over}};
+  return $self;
+}
+
 1;
diff --git a/lib/DX/Solver.pm b/lib/DX/Solver.pm
index c425b27..51fcdbe 100644
--- a/lib/DX/Solver.pm
+++ b/lib/DX/Solver.pm
@@ -17,6 +17,7 @@ has observation_policy => (is => 'ro');
 sub query {
   my ($self, $vars, @terms) = @_;
   my $rule_set = $self->rule_set;
+  push @terms, map +[ materialize => $_ ], @$vars;
   my $head = reduce { $b->but(next => $a) }
                reverse map $rule_set->expand(@$_), @terms;
   my $state = DX::State->new(
diff --git a/lib/DX/State.pm b/lib/DX/State.pm
index 83e8cc3..7ef08c7 100644
--- a/lib/DX/State.pm
+++ b/lib/DX/State.pm
@@ -1,7 +1,7 @@
 package DX::State;
 
 use Return::MultiLevel qw(with_return);
-use DX::Op::FromCode;
+use DX::Op::Backtrack;
 use Scalar::Util qw(blessed);
 use Moo;
 
@@ -97,23 +97,36 @@ sub then {
 
 sub return_from_run {
   my (undef, $return) = @_;
-  (our $Nonlocal_Return)->($return);
+  (our $Run_Return)->($return);
+}
+
+sub return_from_op {
+  my (undef, $return) = @_;
+  if (our $Op_Return) {
+    $Op_Return->($return);
+  }
 }
 
 sub run {
   my ($state) = @_;
   with_return {
     my ($return) = @_;
-    local our $Nonlocal_Return = $return;
+    local our $Run_Return = $return;
     while (my $op = $state->next_op) {
-      $state = $op->run($state);
+      my $backtrack = with_return {
+        my ($return) = @_;
+        local our $Op_Return = $return;
+        $state = $op->run($state);
+        return;
+      };
+      if ($backtrack) { $state = $state->backtrack }
     }
     return $state;
   }
 }
 
 sub push_backtrack {
-  $_[0]->then(DX::Op::FromCode->new(code => sub { $_[1]->backtrack }));
+  $_[0]->then(DX::Op::Backtrack->new);
 }
 
 sub but {
diff --git a/lib/DX/Var.pm b/lib/DX/Var.pm
index eafa895..d17f375 100644
--- a/lib/DX/Var.pm
+++ b/lib/DX/Var.pm
@@ -7,9 +7,15 @@ has id => (is => 'ro', required => 1);
 has bound_stream => (is => 'ro');
 
 has bound_value => (is => 'lazy', predicate => 1, clearer => 1, builder => sub {
-  $_[0]->bound_stream->next;
+  if (defined(my $next = $_[0]->bound_stream->next)) {
+    return $next;
+  }
+  DX::State->return_from_op('backtrack');
+  return;
 });
 
+has action => (is => 'ro');
+
 sub is_bound {
   my ($self) = @_;
   $self->has_bound_value || $self->bound_stream;
@@ -25,4 +31,14 @@ sub with_value {
   $self->new(%$self, bound_value => $stream);
 }
 
+sub with_action {
+  my ($self, $action) = @_;
+  $self->new(%$self, action => $action);
+}
+
+sub copy {
+  my ($self) = @_;
+  ref($self)->new(%$self);
+}
+
 1;
diff --git a/t/basic.t b/t/basic.t
index be3e32d..10e5d62 100644
--- a/t/basic.t
+++ b/t/basic.t
@@ -78,7 +78,7 @@ sub make_state {
 
 my $stream = DX::ResultStream->new(for_state => make_state([ 'S' ], $op));
 
-is($stream->next->{'S'}, $_)
+is($stream->next->{'S'}->bound_value, $_)
   for qw(jim.example.com joe.example.com bob.example.com);
 
 is($stream->next, undef, 'No more');
@@ -96,12 +96,21 @@ my $complex_op = FromCode->new(
   )
 );
 
+sub bound_values {
+  map {
+    my $v = $_;
+    +{
+       map +($_ => $v->{$_}->bound_value), keys %$v
+    }
+  } @_
+}
+
 my $cstream = DX::ResultStream->new(
   for_state => make_state([ qw(S P) ], $complex_op)
 );
 
 is_deeply(
-  [ $cstream->results ],
+  [ bound_values $cstream->results ],
   [
     { P => 'csh', S => 'jim.example.com' },
     { P => 'csh', S => 'joe.example.com' },
@@ -141,7 +150,7 @@ my $callstream = DX::ResultStream->new(
 );
 
 is_deeply(
-  [ $callstream->results ],
+  [ bound_values $callstream->results ],
   [
     { P => 'csh', S => 'jim.example.com' },
     { P => 'csh', S => 'joe.example.com' },
@@ -182,7 +191,7 @@ my $orstream = DX::ResultStream->new(
 );
 
 is_deeply(
-  [ $orstream->results ],
+  [ bound_values $orstream->results ],
   [
     {
       S => "kitty.scsys.co.uk"
@@ -218,7 +227,7 @@ my $orstream_2 = DX::ResultStream->new(
 );
 
 is_deeply(
-  [ $orstream_2->results ],
+  [ bound_values $orstream_2->results ],
   [
     {
       S => "jim.example.com"
diff --git a/t/basic_rule.t b/t/basic_rule.t
index 173b47b..72b9621 100644
--- a/t/basic_rule.t
+++ b/t/basic_rule.t
@@ -45,9 +45,9 @@ $solver->add_rule(
   server => [ 'S' ] => [ member_of => S => [ value => 'servers' ] ]
 );
 
-my $s = $solver->query([ 'S' ], [ call => server => 'S' ]);
+my $s = $solver->query([ 'S' ], [ server => 'S' ]);
 
-is_deeply([ map $_->{S}{name}, $s->results ], [ sort @servers ]);
+is_deeply([ map $_->{S}->bound_value->{name}, $s->results ], [ sort @servers ]);
 
 $solver->add_rule(
   shell => [ 'S' ] => [ member_of => S => [ value => 'shells' ] ])
@@ -69,7 +69,7 @@ $s = $solver->query(
      );
 
 is_deeply(
-  [ sort map $_->{Srv}{name}, $s->results ],
+  [ sort map $_->{Srv}->bound_value->{name}, $s->results ],
   [ qw(joe.example.com kitty.scsys.co.uk) ]
 );
 
diff --git a/t/dot_ssh.t b/t/dot_ssh.t
index 7a3491d..6e4b017 100644
--- a/t/dot_ssh.t
+++ b/t/dot_ssh.t
@@ -3,6 +3,7 @@ use Test::More;
 use DX::Solver;
 use DX::SetOver;
 use DX::Observer::FromCode;
+use DX::Action::FromCode;
 use Test::Exception;
 
 {
@@ -11,7 +12,7 @@ use Test::Exception;
   use Moo;
 
   has path => (is => 'ro', required => 1);
-  has info => (is => 'ro', required => 1);
+  has info => (is => 'ro');
 
   package My::PathStatusInfo;
 
@@ -35,6 +36,12 @@ my %protos = (
   ),
 );
 
+my %empty = (
+  '.ssh' => My::PathStatus->new(
+    path => '.ssh'
+  )
+);
+
 my %path_status;
 
 my $solver = DX::Solver->new(
@@ -51,7 +58,12 @@ $solver->add_rule(@$_) for (
     [ constrain => [ qw(PS P) ], sub { $_[0]->path eq $_[1] } ] ],
   [ mode => [ qw(PS M) ],
     [ constrain => [ qw(PS M) ],
-       sub { $_[0]->info and $_[0]->info->mode eq $_[1] } ] ],
+        sub { $_[0]->info and $_[0]->info->mode eq $_[1] } ] ],
+  [ exists_path => [ qw(PS) ],
+    [ constrain => [ qw(PS) ],
+        sub {
+          $_[0]->info and ($_[0]->info->is_directory or $_[0]->info->is_file)
+        } ] ],
   [ is_directory => [ qw(PS) ],
     [ constrain => [ qw(PS) ],
         sub { $_[0]->info and $_[0]->info->is_directory } ] ],
@@ -63,7 +75,7 @@ $solver->add_rule(@$_) for (
 %path_status = %protos;
 
 sub paths_for_simple {
-  join ' ', map $_->{PS}->path, $solver->query(
+  join ' ', map $_->{PS}->bound_value->path, $solver->query(
     [ qw(PS) ], [ path_status => 'PS' ], @_
   )->results;
 }
@@ -115,7 +127,7 @@ lives_ok {
   )->results
 };
 
-is(join(' ', map $_->{PS}->path, @res), '.ssh');
+is(join(' ', map $_->{PS}->bound_value->path, @res), '.ssh');
 
 delete $solver->rule_set->rules->{'path_status_at/2'};
 
@@ -142,12 +154,12 @@ $solver->add_rule(
     [ path => qw(PS P) ],
 );
 
-%path_status = ('.ssh/authorized_keys' => $protos{'.ssh/authorized_keys'});
+%path_status = ();
 
 $ob_res{'.ssh'} = $protos{'.ssh'};
 
 sub paths_for {
-  join ' ', map $_->{PS}->path, $solver->query([ 'PS' ], @_)->results;
+  join ' ', map $_->{PS}->bound_value->path, $solver->query([ 'PS' ], @_)->results;
 }
 
 is(
@@ -174,4 +186,85 @@ delete $solver->{observation_policy};
 lives_ok { paths_for([ path_status_at => 'PS', [ value => '.ssh' ] ]) }
   'No observation required anymore';
 
+$path_status{'.ssh/authorized_keys'} = $protos{'.ssh/authorized_keys'};
+
+is(
+  paths_for([ path_status => 'PS' ], [ not => [ is_directory => 'PS' ] ]),
+  '.ssh/authorized_keys',
+  'Negation'
+);
+
+$solver->add_rule(@$_) for (
+  [ directory_at => [ qw(PS P) ],
+    [ path_status_at => qw(PS P) ],
+    [ is_directory => 'PS' ] ],
+);
+
+%path_status = ();
+
+$ob_res{'.ssh'} = $empty{'.ssh'};
+
+#%path_status = %protos;
+
+$solver->{observation_policy} = sub { 1 };
+
+sub dot_ssh_query {
+  $solver->query([ 'PS' ], [ directory_at => 'PS' => [ value => '.ssh' ] ]);
+}
+
+is_deeply(
+  [ dot_ssh_query()->results ],
+  []
+);
+
+#::Dwarn(paths_for([ directory_at => 'PS', [ value => '.ssh' ] ]));
+
+$solver->add_rule(@$_) for (
+  [ is_directory => [ qw(PS) ],
+    [ not => [ exists_path => 'PS' ] ],
+    [ act => [ 'PS' ],
+        sub {
+          my ($ps_var) = @_;
+          my ($id, $value) = ($ps_var->id, $ps_var->bound_value);
+          DX::Action::FromCode->new(
+            expect => sub {
+              ($id => My::PathStatus->new(
+                path => $value->path,
+                info => My::PathStatusInfo->new(
+                  is_directory => 1, mode => ''
+                )
+              ))
+            },
+            perform => sub {
+              $ob_res{$value->path} = $protos{$value->path};
+              (path_status => $value);
+            }
+          )
+        } ] ]
+);
+
+%path_status = ();
+
+@res = dot_ssh_query()->results;
+
+is(scalar(@res),1,'Single result');
+
+is($path_status{'.ssh'}, $empty{'.ssh'}, 'Empty observed');
+
+ok(my $action = $res[0]->{PS}->action);
+
+my ($type, $value) = $action->run;
+
+$solver->facts->{$type}->remove_value($value);
+
+ok(!$path_status{'.ssh'}, 'Empty retracted');
+
+@res = dot_ssh_query()->results;
+
+is(scalar(@res),1,'Single result');
+
+is($path_status{'.ssh'}, $protos{'.ssh'}, 'Created observed');
+
+ok(!$res[0]->{PS}->action, 'No action');
+
 done_testing;
diff --git a/t/observe.t b/t/observe.t
index 7896be3..70b70c1 100644
--- a/t/observe.t
+++ b/t/observe.t
@@ -2,7 +2,6 @@ use strictures 1;
 use Test::More;
 use aliased 'DX::Op::FromCode';
 use aliased 'DX::ArrayStream';
-use DX::ResultStream;
 use DX::Var;
 use DX::State;
 use DX::ObservationRequired;
diff --git a/t/ssh_key.t b/t/ssh_key.t
index b7ed6ed..ef61682 100644
--- a/t/ssh_key.t
+++ b/t/ssh_key.t
@@ -1,6 +1,5 @@
 use strictures 1;
 use Test::More;
-use Unknown::Values;
 use List::Util qw(reduce);
 use aliased 'DX::Op::FromCode';
 use DX::Var;