From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sat, 12 Mar 2016 18:57:45 +0000 (+0000)
Subject: rules are created and installed. they just don't work yet.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2bf57c95aec1313620d098a3580b8fbab47a97ca;p=scpubgit%2FDX.git

rules are created and installed. they just don't work yet.
---

diff --git a/lib/DX/Predicate/Rule.pm b/lib/DX/Predicate/Rule.pm
new file mode 100644
index 0000000..c599ea5
--- /dev/null
+++ b/lib/DX/Predicate/Rule.pm
@@ -0,0 +1,11 @@
+package DX::Predicate::Rule;
+
+use DX::Class;
+
+with 'DX::Role::Predicate';
+
+has arg_names => (is => 'ro', required => 1);
+
+has proposition_sequence => (is => 'ro', required => 1);
+
+1;
diff --git a/lib/DX/RuleDefinitionContext.pm b/lib/DX/RuleDefinitionContext.pm
new file mode 100644
index 0000000..6d192c2
--- /dev/null
+++ b/lib/DX/RuleDefinitionContext.pm
@@ -0,0 +1,48 @@
+package DX::RuleDefinitionContext;
+
+use DX::PropositionSequence;
+use DX::Predicate::Rule;
+use DX::Class;
+
+has arg_names => (is => 'ro', required => 1);
+
+has proposition_sequence => (is => 'rwp', lazy => 1, builder => sub {
+  my ($self) = @_;
+  my %arg_names = map +($_ => 1), @{$self->arg_names};
+  DX::PropositionSequence->new_empty
+                         ->but(external_names => \%arg_names);
+});
+
+has expander => (is => 'ro', required => 1, handles => [ qw(expand_args) ]);
+
+sub apply_predicate {
+  my ($self, $pred, @arg_strings) = @_;
+  my @args = $self->expand_args(@arg_strings);
+  my ($intro, $need) = ({}, {});
+  foreach my $arg (@args) {
+    next if ref($arg);
+    next if $arg =~ /^\??[a-z]/; # skip globals
+    # ?Foo is intro, Foo is need
+    ($arg =~ s/^\?// ? $intro : $need)->{$arg} = 1;
+  }
+  my $prop = DX::Proposition->new(
+    predicate => $pred,
+    args => \@args,
+    introduced_names => $intro,
+    required_names => $need,
+  );
+  $self->_set_proposition_sequence(
+    $self->proposition_sequence->with_additional_proposition($prop)
+  );
+  return;
+}
+
+sub bake_rule {
+  my ($self) = @_;
+  DX::Predicate::Rule->new(
+    arg_names => $self->arg_names,
+    proposition_sequence => $self->proposition_sequence
+  );
+}
+
+1;
diff --git a/lib/DX/ShellSession.pm b/lib/DX/ShellSession.pm
index db3bb0b..ecb93d8 100644
--- a/lib/DX/ShellSession.pm
+++ b/lib/DX/ShellSession.pm
@@ -5,6 +5,7 @@ use Scalar::Util qw(weaken);
 use DX::Expander;
 use DX::Proposition;
 use DX::ActionBuilder::Normal;
+use DX::RuleDefinitionContext;
 use DX::Utils qw(deparse);
 use DX::Class;
 
@@ -77,7 +78,7 @@ has tcl => (is => 'lazy', builder => sub {
   ) {
     $tcl->CreateCommand($pred => sub {
       my (undef, undef, undef, @args) = @_; # ($data, $interp, $pred)
-      $self->apply_predicate($pred => @args);
+      (our $Shell_Context)->apply_predicate($pred => @args);
     });
   }
   $tcl->CreateCommand(const => sub {
@@ -116,6 +117,31 @@ has tcl => (is => 'lazy', builder => sub {
       $self->shell_state->with_trace_changes(@trace)
     );
   });
+  $tcl->CreateCommand(rule => sub {
+    my (undef, undef, undef, $pred, $args, $body) = @_;
+    local our $Shell_Context = DX::RuleDefinitionContext->new(
+                                 arg_names => [ $self->tcl->SplitList($args) ],
+                                 expander => $self->expander,
+                               );
+    $self->tcl->Eval($body);
+    my $rule = $Shell_Context->bake_rule;
+    my $tqs = $self->shell_state->template_query_state;
+    my $new_tqs = $tqs->but(
+      predicates => {
+        %{$tqs->predicates},
+        $pred => $rule,
+      },
+    );
+    $self->_set_shell_state(
+      $self->shell_state->but(
+        template_query_state => $new_tqs
+      ),
+    );
+    $self->tcl->CreateCommand($pred => sub {
+      my (undef, undef, undef, @args) = @_; # ($data, $interp, $pred)
+      (our $Shell_Context)->apply_predicate($pred => @args);
+    });
+  });
   return $tcl;
 });
 
@@ -143,6 +169,7 @@ sub eval_command_string {
   try {
     no warnings 'redefine';
     local *DX::Utils::trace = $self->shell_state->trace_sub;
+    local our $Shell_Context = $self;
     $self->tcl->Eval($string);
   } catch {
     push @Result, [ output => $_ ];