better action debug info

[scpubgit/DKit.git] / lib / DX / Tcl.pm

diff --git a/lib/DX/Tcl.pm b/lib/DX/Tcl.pm
index 2a9955a..239a77c 100644 (file)
--- a/lib/DX/Tcl.pm
+++ b/lib/DX/Tcl.pm
@@ -70,17 +70,31 @@ sub _tcl_ensure_result {
   return $result ? $self->_implode_result($result) : 'false';
 }
 
+sub _tcl_set_action_cb {
+  my ($self, @cb) = @_;
+  my $get_tcl = $self->curry::weak::tcl;
+  my $implode = $self->curry::weak::_implode_action;
+  $self->solver->action_callback(sub {
+    $get_tcl->()->call(@cb, $implode->($_[0]));
+  });
+  return;
+}
+
 sub _implode_result {
   my ($self, $result) = @_;
   my $imploded = $self->_implode_hashref($result->all_values);
   if (my @act = $result->actions) {
-    my @flat_act = map +($_->[0], $self->_implode_hashref($_->[1])),
-                     map [ %{$_->as_structure} ], @act;
+    my @flat_act = map $self->_implode_action, @act;
     unshift @$imploded, +(_actions => \@flat_act);
   }
   return $imploded;
 }
 
+sub _implode_action {
+  my ($self, $action) = @_;
+  map +($_->[0], $self->_implode_hashref($_->[1])), [ %{$action->as_structure} ];
+}
+
 sub _implode_hashref {
   my ($self, $values) = @_;
   my @flat;
@@ -182,6 +196,12 @@ namespace eval DX {
     return [format_response $res $out]
   }
 
+  proc format_action {type data} {
+    set flat "$type ->\n";
+    append flat [format_response $data "" "  "]
+    return $flat
+  }
+
   proc format_response {res out {i ""}} {
     if {[llength $res] < 2} {
       return "${i}$res\n";
@@ -192,8 +212,7 @@ namespace eval DX {
     set flat ""
     if [dict exists $res _actions] {
       foreach {n v} [dict get $res _actions] {
-        append flat "$n -> \n";
-        append flat [format_response $v "" "  "]
+        append flat [format_action $type $data]
       }
       append flat "->\n";
     }
@@ -251,6 +270,12 @@ namespace eval DX {
     return [lmap x $raw { mangle_arg $x }]
   }
 
+  proc action_cb args {
+    _call set_action_cb {*}$args
+  }
+
+  action_cb apply {{n v} {puts [DX::format_action $n $v]}}
+
   namespace eval ::DX::Eval {
     proc findall args { DX::body_add findall $args }
     proc foreach args { DX::body_add foreach $args }