better debugging output

[scpubgit/DKit.git] / bin / dx-shell

diff --git a/bin/dx-shell b/bin/dx-shell
index 20a5b6b..b540453 100644 (file)
--- a/bin/dx-shell
+++ b/bin/dx-shell
@@ -5,6 +5,10 @@ use curry;
 use DX::Solver;
 use DX::Lib::FS;
 use Term::ReadLine;
+use Devel::Dwarn;
+use Sub::Quote;
+use YAML ();
+use Safe::Isa;
 
 my $solver = DX::Solver->new(observation_policy => sub { 1 });
 
@@ -21,36 +25,75 @@ my $tcl = Tcl->new;
 
 my $split = $tcl->curry::weak::SplitList;
 
-my (@res, @last_q);
+my ($r, $res, @last_q);
+
+my $last_mode;
+
+sub show {
+  $r = ($res->isa('DX::Result') ? $res : $res->next);
+  unless ($r) { warn "false\n"; return; }
+  if (my @act = $r->actions) {
+    warn YAML::Dump([ map $_->as_structure, @act ]);
+  }
+  my $values = $r->all_values;
+  unless (keys %$values) {
+    warn "---\ntrue\n"; return;
+  }
+  warn YAML::Dump({
+    map +($_ => ($values->{$_}->$_does('DX::Role::Set')
+                  ? [ $values->{$_}->all ]
+                  : $values->{$_} )),
+      keys %$values
+  });
+}
 
 sub do_query {
-  @res = $solver->query(@last_q)->results;
-  Dwarn([ map {
-    my @act = $_->actions;
-    ((@act ? \@act : ()), $_->all_values);
-  } @res ]);
+  $res = $solver->$last_mode(@last_q);
+  show();
 }
 
-$tcl->CreateCommand(query => sub {
-  my (undef, undef, undef, $vars, $body) = @_;
+sub expand_def {
+  my ($vars, $body) = @_;
   my @varnames = $split->($vars);
+  return (\@varnames, expand_body($body));
+}
+
+sub expand_body {
+  my (@body) = @_;
   local our @Body_Parts;
-  $tcl->Eval($body);
-  @last_q = (\@varnames, @Body_Parts);
+  $tcl->Eval(@body);
+  return @Body_Parts;
+}
+
+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();
   return;
 });
 
+$tcl->CreateCommand(dump => sub {
+  my (undef, undef, undef, $to_dump) = @_;
+  my $filter = quote_sub($to_dump);
+  Dwarn($filter->($r));
+});
+
 sub mangle_args {
   my @args = @_;
   map { $_ =~ /^'(.*)'$/ ? \do { my $x = $1 } : $_ } @args;
@@ -62,13 +105,42 @@ my $rule_sub = sub {
   return;
 };
 
+$tcl->CreateCommand(rule => sub {
+  my (undef, undef, undef, $rule, $vars, $body) = @_;
+  $solver->add_rule($rule => expand_def($vars, $body));
+  $tcl->CreateCommand($rule => $rule_sub);
+  return;
+});
+
 foreach my $rule (keys %{$solver->rule_set->rules}) {
   $rule =~ s/\/\d+$//;
   $tcl->CreateCommand($rule => $rule_sub);
 }
+
+$tcl->CreateCommand(foreach => sub {
+  my (undef, undef, undef, $var, $body, $each_body) = @_;
+  push our @Body_Parts, [
+    foreach => $var => map [ expand_body($_) ], $body, $each_body
+  ];
+  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->CreateCommand(n => \&show);
   
 #$tcl->Eval(q{query D {directory_at D 't'; mode D '0755'; }});
 
+if ($ARGV[0]) {
+  $tcl->EvalFile($ARGV[0]);
+}
+
 my $rl = Term::ReadLine->new;
 
 my $cmd;
@@ -76,7 +148,9 @@ my $cmd;
 while (defined(my $line = $rl->readline(length($cmd)?'> ':'$ '))) {
   $cmd .= "${line}\n";
   if ($tcl->call(info => complete => $cmd)) {
-    $tcl->Eval($cmd);
+    unless (eval { $tcl->Eval($cmd); 1 }) {
+      warn $@;
+    }
     $cmd = '';
   }
 }