finish adding type constraints

[scpubgit/DX.git] / lib / DX / ShellSession.pm

diff --git a/lib/DX/ShellSession.pm b/lib/DX/ShellSession.pm
index a24a106..255a089 100644 (file)
--- a/lib/DX/ShellSession.pm
+++ b/lib/DX/ShellSession.pm
@@ -4,17 +4,20 @@ use Tcl;
 use Scalar::Util qw(weaken);
 use DX::Expander;
 use DX::Proposition;
+use DX::ActionBuilder::Normal;
+use DX::RuleDefinitionContext;
 use DX::Utils qw(deparse);
+use Types::Standard qw(InstanceOf);
 use DX::Class;
 
 has shell_state => (is => 'rwp', required => 1, isa => ShellState);
 
 has expander => (
   is => 'lazy', builder => sub { DX::Expander->new(tcl => $_[0]->tcl) },
-  handles => [ qw(expand_args) ],
+  isa => Expander, handles => [ qw(expand_args) ],
 );
 
-has tcl => (is => 'lazy', builder => sub {
+has tcl => (is => 'lazy', isa => InstanceOf['Tcl'], builder => sub {
   my ($self) = @_;
   weaken $self;
   my $tcl = Tcl->new;
@@ -31,7 +34,7 @@ has tcl => (is => 'lazy', builder => sub {
   });
   $tcl->CreateCommand('...' => sub {
     $self->apply_to_state([ mode => 'shell' ]);
-    my ($cur) = $self->shell_state->current_query_state;
+    my $orig = my $cur = $self->shell_state->current_query_state;
     while ($cur) {
       $self->_set_shell_state(
         $self->shell_state->but(current_query_state => $cur)
@@ -40,6 +43,12 @@ has tcl => (is => 'lazy', builder => sub {
       $cur = eval { $cur->with_forced_backtrack };
       push our @Result, [ output => $@ ] if $@;
     }
+    $self->_set_shell_state(
+      $self->shell_state->but(
+        current_query_state => $orig
+      ),
+    );
+    return;
   });
   $tcl->CreateCommand(qlist => sub {
     push our @Result, map [ output => $_ ], @{
@@ -70,7 +79,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 {
@@ -78,7 +87,9 @@ has tcl => (is => 'lazy', builder => sub {
     my $tqs = $self->shell_state->template_query_state;
     my $new_tqs = $tqs->but(
       globals => $tqs->globals->with_member_at(
-        $name => $self->expand_args($value),
+        $name => DX::ActionBuilder::Null->new(
+                   target_path => [ $name ],
+                 )->apply_to_value($self->expand_args($value)),
       ),
     );
     $self->_set_shell_state(
@@ -87,6 +98,53 @@ has tcl => (is => 'lazy', builder => sub {
       ),
     );
   });
+  $tcl->CreateCommand(state => sub {
+    my (undef, undef, undef, $name, $value) = @_;
+    my $tqs = $self->shell_state->template_query_state;
+    my $new_tqs = $tqs->but(
+      globals => $tqs->globals->with_member_at(
+        $name => DX::ActionBuilder::Normal->new(
+                   target_path => [ $name ],
+                 )->apply_to_value($self->expand_args($value)),
+      ),
+    );
+    $self->_set_shell_state(
+      $self->shell_state->but(
+        template_query_state => $new_tqs
+      ),
+    );
+  });
+  $tcl->CreateCommand(trace => sub {
+    my (undef, undef, undef, @trace) = @_;
+    $self->_set_shell_state(
+      $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;
 });
 
@@ -114,6 +172,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 => $_ ];