From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sat, 5 Mar 2016 06:36:56 +0000 (+0000)
Subject: add qlist debug predicate, actually add propositions to the query state
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d1b6cb33ee82ad278042329e000c5de414692cbe;p=scpubgit%2FDX.git

add qlist debug predicate, actually add propositions to the query state
---

diff --git a/lib/DX/Expander.pm b/lib/DX/Expander.pm
index cd63313..9f8639d 100644
--- a/lib/DX/Expander.pm
+++ b/lib/DX/Expander.pm
@@ -26,7 +26,8 @@ my @exp_t = map { [ qr/\A(\s*)${\$_->[1]}\s*\Z/, 'expand_'.$_->[0] ] } (
   [ number => qr/([\d.]+)/ ],
   [ string => qr/'(.*)'/s ],
   [ bool => qr/(true|false)/ ],
-  [ symbol => qr/([a-zA-Z_][a-zA-Z0-9_]*)/ ],
+  # foo or Foo or ?Foo or _Foo or ?_Foo
+  [ symbol => qr/((?:[a-z]|\??[A-Z_])[a-zA-Z0-9_]*)/ ],
   [ dict => qr/{(.*)}/s ],
   [ array => qr/\[(.*)\]/s ],
 );
diff --git a/lib/DX/Proposition.pm b/lib/DX/Proposition.pm
index d67e2de..56d1d2a 100644
--- a/lib/DX/Proposition.pm
+++ b/lib/DX/Proposition.pm
@@ -6,6 +6,10 @@ has predicate => (is => 'ro', required => 1);
 
 has args => (is => 'ro', required => 1);
 
+has introduces_names => (is => 'ro', required => 1);
+
+has requires_names => (is => 'ro', required => 1);
+
 sub resolve_for {
   my ($self, $scope) = @_;
   my $predicate = $scope->lookup_predicate($self->predicate);
diff --git a/lib/DX/ShellSession.pm b/lib/DX/ShellSession.pm
index 1e6cdc7..5fc19e1 100644
--- a/lib/DX/ShellSession.pm
+++ b/lib/DX/ShellSession.pm
@@ -3,6 +3,8 @@ package DX::ShellSession;
 use Tcl;
 use Scalar::Util qw(weaken);
 use DX::Expander;
+use DX::Proposition;
+use DX::Utils qw(deparse);
 use DX::Class;
 
 has shell_state => (is => 'rwp', required => 1, isa => ShellState);
@@ -25,6 +27,12 @@ has tcl => (is => 'lazy', builder => sub {
   $tcl->CreateCommand('.' => sub {
     $self->apply_to_state([ mode => 'shell' ])
   });
+  $tcl->CreateCommand(qlist => sub {
+    push our @Result, map [ output => $_ ], @{
+      $self->shell_state->current_query_state->proposition_sequence->members
+    };
+    return;
+  });
   foreach my $pred (
     keys %{$self->shell_state->template_query_state->predicates}
   ) {
@@ -62,14 +70,41 @@ sub eval_command_string {
   } catch {
     push @Result, [ output => $_ ];
   };
-  return @Result;
+  return map {
+    ($_->[0] eq 'output' and ref($_->[1]))
+      ? [ output => deparse($_->[1]) ]
+      : $_
+  } @Result;
 }
 
 sub apply_predicate {
-  my ($self, $pred, @args) = @_;
+  my ($self, $pred, @arg_strings) = @_;
   die "Can't call predicate ${pred} outside a query\n"
     unless $self->shell_state->mode eq 'query';
-use Data::Dumper::Concise; die Dumper [ $pred, $self->expand_args(@args) ];
+  my @args = $self->expand_args(@arg_strings);
+  my $intro; my $need;
+  foreach my $arg (@args) {
+    next if ref($arg);
+    # ?Foo is intro, Foo is need
+    ($arg =~ s/^\?// ? $intro : $need)->{$arg} = 1;
+  }
+  my $prop = DX::Proposition->new(
+    predicate => $pred,
+    args => \@args,
+    introduces_names => $intro,
+    requires_names => $need,
+  );
+  my $qstate = $self->shell_state->current_query_state;
+  $qstate = $qstate->but(
+    proposition_sequence => $qstate->proposition_sequence
+                                   ->but_append_proposition($prop)
+  );
+  $self->_set_shell_state(
+    $self->shell_state->but(
+      current_query_state => $qstate
+    )
+  );
+  return;
 }
 
 1;