From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sat, 22 Feb 2014 19:33:40 +0000 (+0000)
Subject: query/solve/ensure
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7ca660cb75c4248a653dd68036227e309faaac9b;p=scpubgit%2FDKit.git

query/solve/ensure
---

diff --git a/bin/dx-shell b/bin/dx-shell
index 1865982..725fc10 100644
--- a/bin/dx-shell
+++ b/bin/dx-shell
@@ -23,14 +23,22 @@ my $tcl = Tcl->new;
 
 my $split = $tcl->curry::weak::SplitList;
 
-my (@res, @last_q);
+my ($r, $res, @last_q);
 
-sub do_query {
-  @res = $solver->query(@last_q)->results;
-  Dwarn([ map {
+my $last_mode;
+
+sub show {
+  $r = ($res->isa('DX::Result') ? $res : $res->next);
+  unless ($r) { warn "false\n"; return; }
+  Dwarn(map {
     my @act = $_->actions;
     ((@act ? \@act : ()), $_->all_values);
-  } @res ]);
+  } $r);
+}
+
+sub do_query {
+  $res = $solver->$last_mode(@last_q);
+  show();
 }
 
 sub expand_def {
@@ -40,23 +48,29 @@ sub expand_def {
 }
 
 sub expand_body {
-  my ($body) = @_;
+  my (@body) = @_;
   local our @Body_Parts;
-  $tcl->Eval($body);
+  $tcl->Eval(@body);
   return @Body_Parts;
 }
 
-$tcl->CreateCommand(query => sub {
-  my (undef, undef, undef, $body) = @_;
-  @last_q = expand_body($body);
+sub q_command {
+  my ($this_mode, undef, undef, undef, $body) = @_;
+  $last_mode = $this_mode;
+  if ($body) {
+    @last_q = expand_body($body);
+  }
   do_query();
   return;
-});
+}
+
+$tcl->CreateCommand('?' => sub { q_command(query => @_) });
+$tcl->CreateCommand('?!' => sub { q_command(solve => @_) });
+$tcl->CreateCommand('!?' => sub { q_command(solve => @_) });
+$tcl->CreateCommand('!' => sub { q_command(ensure => @_) });
 
 $tcl->CreateCommand(run => sub {
-  foreach my $ind ($res[0]->independent_actions) {
-    my $cl = ref($ind);
-    warn +(split('::', $cl))[-1]."\n";
+  foreach my $ind ($r->independent_actions) {
     $solver->run_action($ind);
   }
   do_query();
@@ -66,7 +80,7 @@ $tcl->CreateCommand(run => sub {
 $tcl->CreateCommand(dump => sub {
   my (undef, undef, undef, $to_dump) = @_;
   my $filter = quote_sub($to_dump);
-  Dwarn(map $filter->($_), @res);
+  Dwarn($filter->($r));
 });
 
 sub mangle_args {
@@ -99,6 +113,14 @@ $tcl->CreateCommand(foreach => sub {
   ];
   return;
 });
+
+$tcl->CreateCommand(findall => sub {
+  my (undef, undef, undef, $coll_var, $name_var, $body) = @_;
+  push our @Body_Parts, [
+    findall => $coll_var => $name_var => expand_body($body)
+  ];
+  return;
+});
   
 #$tcl->Eval(q{query D {directory_at D 't'; mode D '0755'; }});
 
diff --git a/lib/DX/Op/ProposeAction.pm b/lib/DX/Op/ProposeAction.pm
index e3d1ed2..9db50a5 100644
--- a/lib/DX/Op/ProposeAction.pm
+++ b/lib/DX/Op/ProposeAction.pm
@@ -19,6 +19,7 @@ sub run {
   ($state, my %args) = $self->_expand_args($state, %{$self->_arg_map});
   my @vars = @args{sort keys %args};
   return $state->backtrack unless @vars == grep $_->is_bound, @vars;
+  return $state->backtrack unless $state->allow_actions;
   my @deps = $state->action_dependencies(map $_->id, @vars);
   my $action = $self->builder->(map $state->resolve_value($_), @vars)
                     ->but(dependencies => \@deps);
diff --git a/lib/DX/Role/Op/FindIsh.pm b/lib/DX/Role/Op/FindIsh.pm
index 758070b..64c3621 100644
--- a/lib/DX/Role/Op/FindIsh.pm
+++ b/lib/DX/Role/Op/FindIsh.pm
@@ -41,11 +41,20 @@ sub run {
       $state->then($op);
     }
   );
+  my $allow = $state->allow_actions;
   my $ret = DX::Op::SetScope->new(
     scope => $state->scope,
-    next => $self->make_result_handler($coll),
+    next => DX::Op::FromCode->new(
+      code => sub {
+        my ($self, $state) = @_;
+        $state->but(allow_actions => $allow)
+              ->then($self->next);
+      },
+      next => $self->make_result_handler($coll),
+    )
   );
   $state->assign_vars($self->var_name => {})
+        ->but(allow_actions => 0)
         ->push_return_then($ret, $invoke)->mark_choice($var);
 }
 
diff --git a/lib/DX/Solver.pm b/lib/DX/Solver.pm
index 6300b23..753abe5 100644
--- a/lib/DX/Solver.pm
+++ b/lib/DX/Solver.pm
@@ -20,6 +20,28 @@ has observation_policy => (is => 'ro');
 
 sub query {
   my ($self, @terms) = @_;
+  $self->_solve({ allow_actions => 0 }, @terms);
+}
+
+sub solve {
+  my ($self, @terms) = @_;
+  $self->_solve({ allow_actions => 1 }, @terms);
+}
+
+sub ensure {
+  my ($self, @terms) = @_;
+  my $rs = $self->_solve({ allow_actions => 1 }, @terms);
+  my $r = $rs->next;
+  while ($r and $r->actions and my @ind = $r->independent_actions) {
+    $self->run_action($_) for @ind;
+    $rs = $self->_solve({ allow_actions => 1 }, @terms);
+    $r = $rs->next;
+  }
+  return $r;
+}
+
+sub _solve {
+  my ($self, $attrs, @terms) = @_;
   my $rule_set = $self->rule_set;
   my $head = $rule_set->expand_and_link(undef, @terms, [ 'materialize' ]);
   my $state = DX::State->new(
@@ -30,6 +52,7 @@ sub query {
     last_choice => [],
     facts => $self->facts,
     rule_set => $rule_set,
+    %$attrs
   );
   return DX::ResultStream->new(
     for_state => $state,
@@ -41,6 +64,7 @@ sub query {
 
 sub run_action {
   my ($self, $action) = @_;
+  warn +(split('::', ref($action)))[-1]."\n";
   my @invalidate = $action->run;
   while (my ($type, $value) = splice @invalidate, 0, 2) {
     $self->facts->{$type}->remove_value($value);
diff --git a/lib/DX/State.pm b/lib/DX/State.pm
index f9d886b..530c86a 100644
--- a/lib/DX/State.pm
+++ b/lib/DX/State.pm
@@ -25,6 +25,8 @@ has facts => (is => 'ro');
 
 has dependencies => (is => 'ro', default => sub { {} });
 
+has allow_actions => (is => 'ro', default => sub { 1 });
+
 has actions => (is => 'ro', default => sub { {} });
 
 sub has_scope_var {
diff --git a/t/dot_ssh.t b/t/dot_ssh.t
index d55b5d5..b8cb7ec 100644
--- a/t/dot_ssh.t
+++ b/t/dot_ssh.t
@@ -82,7 +82,7 @@ $solver->add_rule(@$_) for (
 %path_status = %protos;
 
 sub paths_for_simple {
-  join ' ', map $_->value_for('PS')->path, $solver->query(
+  join ' ', map $_->value_for('PS')->path, $solver->solve(
     [ path_status => 'PS' ], @_
   )->results;
 }
@@ -106,7 +106,7 @@ $solver->add_rule(
 );
 
 throws_ok {
-  $solver->query(
+  $solver->solve(
     [ path_status_at => 'PS', \'.ssh' ]
   )->results
 } qr/ARGH/;
@@ -127,7 +127,7 @@ $solver->add_rule(
 my @res;
 
 lives_ok {
-  @res = $solver->query(
+  @res = $solver->solve(
     [ path_status_at => 'PS', \'.ssh' ]
   )->results
 };
@@ -164,7 +164,7 @@ $solver->add_rule(
 $ob_res{'.ssh'} = $protos{'.ssh'};
 
 sub paths_for {
-  join ' ', map $_->value_for('PS')->path, $solver->query(@_)->results;
+  join ' ', map $_->value_for('PS')->path, $solver->solve(@_)->results;
 }
 
 is(
@@ -217,7 +217,7 @@ $ob_res{'.ssh'} = $empty{'.ssh'};
 $solver->{observation_policy} = sub { 1 };
 
 sub dot_ssh_query {
-  $solver->query([ directory_at => 'PS' => \'.ssh' ]);
+  $solver->solve([ directory_at => 'PS' => \'.ssh' ]);
 }
 
 is_deeply(
@@ -313,7 +313,7 @@ $solver->add_rule(@$_) for (
 %ob_res = %empty;
 
 sub keys_file {
-  $solver->query(
+  $solver->solve(
      [ directory_at => 'D' => \'.ssh' ],
      [ file_in => 'D' => \'authorized_keys' => 'F' ],
    );