From: Matt S Trout <mst@shadowcat.co.uk>
Date: Fri, 14 Feb 2014 07:14:55 +0000 (+0000)
Subject: add ModifyAction op
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2c467394ea6fef5949570c03c467a2fe3361d81e;p=scpubgit%2FDKit.git

add ModifyAction op
---

diff --git a/lib/DX/Op/ModifyAction.pm b/lib/DX/Op/ModifyAction.pm
new file mode 100644
index 0000000..57696b4
--- /dev/null
+++ b/lib/DX/Op/ModifyAction.pm
@@ -0,0 +1,40 @@
+package DX::Op::ModifyAction;
+
+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 ($subject, @vars) = @args{sort keys %args};
+  die "Can't alter action on $subject" unless
+    my $orig_action = $state->resolve_value($subject)->required_action;
+  my @deps = $state->action_dependencies(
+    @{$orig_action->dependencies},
+    map $_->id, @vars
+  );
+  my @builder_args = (
+    $orig_action,
+    map $state->resolve_value($_), @vars
+  );
+  my $action = $self->builder->(@builder_args)
+                    ->but(dependencies => \@deps);
+  my ($fact_type, $value) = $action->expected_effect;
+  my $final_value = $value->but(required_action => $action);
+  my $fact_set = $state->facts->{$fact_type}->with_value($final_value);
+  $state->but(facts => { %{$state->facts}, $fact_type => $fact_set })
+        ->then($self->next);
+}
+
+1;
diff --git a/lib/DX/RuleSet.pm b/lib/DX/RuleSet.pm
index bc8167f..baa9586 100644
--- a/lib/DX/RuleSet.pm
+++ b/lib/DX/RuleSet.pm
@@ -11,6 +11,7 @@ use DX::Op::Backtrack;
 use DX::Op::Observe;
 use DX::Op::Not;
 use DX::Op::ProposeAction;
+use DX::Op::ModifyAction;
 use DX::Op::Materialize;
 use DX::Op::Prop;
 use DX::Op::Exists;
@@ -108,6 +109,14 @@ sub _expand_op_act {
   );
 }
 
+sub _expand_op_react {
+  my ($self, $vars, $builder) = @_;
+  DX::Op::ModifyAction->new(
+    vars => $vars,
+    builder => $builder,
+  );
+}
+
 sub _expand_op_materialize {
   my ($self, $var_name) = @_;
   DX::Op::Materialize->new(var_name => $var_name);