lib/DX/Tcl.pm

   1 package DX::Tcl;
   2
   3 use strictures 1;
   4 use curry;
   5 use DX::Solver;
   6 use DX::Lib::FS;
   7 use Term::ReadLine;
   8 use Devel::Dwarn;
   9 use Tcl;
  10 use Safe::Isa;
  11 use Moo;
  12
  13 has solver => (is => 'lazy', builder => sub {
  14   my $solver = DX::Solver->new(observation_policy => sub { 1 });
  15   DX::Lib::FS->new->load_into($solver);
  16   $solver;
  17 });
  18
  19 has tcl => (is => 'lazy', builder => sub {
  20   my ($self) = @_;
  21   my $tcl = Tcl->new;
  22   $tcl->CreateCommand('DX::_call' => $self->curry::weak::handle_tcl_call);
  23   our $Tcl_Data ||= do { local $/; my $data = <DATA>; close(DATA); $data };
  24   $tcl->Eval($Tcl_Data);
  25   $tcl->call(namespace => import => 'DX::*');
  26   return $tcl;
  27 });
  28
  29 sub handle_tcl_call {
  30   my ($self, undef, undef, undef, $call, @args) = @_;
  31   return $self->${\"_tcl_${call}"}(@args);
  32   #Dwarn(\@stuff);
  33   return 1;
  34 }
  35
  36 sub _tcl_rule_names {
  37   my ($self) = @_;
  38   return [ map /(.*)\/(\d+)/, keys %{$self->solver->rule_set->rules} ];
  39 }
  40
  41 sub _tcl_add_rule {
  42   my ($self, $name, $args, $raw_body) = @_;
  43   my @args = $self->tcl->SplitList($args);
  44   #warn $raw_body;
  45   my $body = $self->_expand_tcl_data($raw_body);
  46   #Dwarn([ $name, \@args, @$body ]);
  47   $self->solver->add_rule($name => \@args => @$body);
  48   return;
  49 }
  50
  51 sub _tcl_first_result {
  52   my ($self, $type, $raw_query) = @_;
  53   my $query = $self->_expand_tcl_data($raw_query);
  54   my $rs = $self->solver->$type(@$query);
  55   my $result = $rs->next;
  56   return $result ? $self->_implode_result($result) : 'false';
  57 }
  58
  59 sub _tcl_each_result {
  60   my ($self, $type, $raw_query) = @_;
  61   my $query = $self->_expand_tcl_data($raw_query);
  62   my $rs = $self->solver->$type(@$query);
  63   return [ map $self->_implode_result($_), $rs->results ];
  64 }
  65
  66 sub _tcl_ensure_result {
  67   my ($self, $raw_query) = @_;
  68   my $query = $self->_expand_tcl_data($raw_query);
  69   my $result = $self->solver->ensure(@$query);
  70   return $result ? $self->_implode_result($result) : 'false';
  71 }
  72
  73 sub _tcl_set_action_cb {
  74   my ($self, @cb) = @_;
  75   my $get_tcl = $self->curry::weak::tcl;
  76   my $implode = $self->curry::weak::_implode_action;
  77   $self->solver->action_callback(sub {
  78     $get_tcl->()->call(@cb, $implode->($_[0]));
  79   });
  80   return;
  81 }
  82
  83 sub _implode_result {
  84   my ($self, $result) = @_;
  85   my $imploded = $self->_implode_hashref($result->all_values);
  86   if (my @act = $result->actions) {
  87     my @flat_act = map $self->_implode_action, @act;
  88     unshift @$imploded, +(_actions => \@flat_act);
  89   }
  90   return $imploded;
  91 }
  92
  93 sub _implode_action {
  94   my ($self, $action) = @_;
  95   map +($_->[0], $self->_implode_hashref($_->[1])), [ %{$action->as_structure} ];
  96 }
  97
  98 sub _implode_hashref {
  99   my ($self, $values) = @_;
 100   my @flat;
 101   my %meta;
 102   foreach my $key (sort keys %$values) {
 103     my $v = $values->{$key};
 104     if ($v->$_does('DX::Role::Set')) {
 105       $meta{$key}{is_list} = 1;
 106       push @flat, ($key => [ map "$_", $v->all ]);
 107     } elsif (ref($v) and ref($v) eq 'ARRAY') {
 108       $meta{$key}{is_list} = 1;
 109       push @flat, ($key => [ map "$_", @$v ]);
 110     } else {
 111       push @flat, ($key => "$v");
 112     }
 113   }
 114   my @flat_meta = map +($_ => [ %{$meta{$_}} ]), sort keys %meta;
 115   return [ (@flat_meta ? (_meta => \@flat_meta) : ()), @flat ];
 116 }
 117
 118 sub _expand_tcl_data {
 119   my ($self, $data) = @_;
 120   my ($type, @rest) = $self->tcl->SplitList($data);
 121   die "No type" unless $type;
 122   if ($type eq 'seq') {
 123     return [ map $self->_expand_tcl_data($_), @rest ];
 124   } elsif ($type eq 'call') {
 125     my ($name, @args) = @rest;
 126     return [ $name => map $self->_expand_tcl_data($_), @args ];
 127   } elsif ($type eq 'var') {
 128     return $rest[0];
 129   } elsif ($type eq 'value') {
 130     return \$rest[0]
 131   }
 132   die "Unknown type ${type}";
 133 }
 134
 135 sub run { shift->repl }
 136
 137 sub repl {
 138   my ($self) = @_;
 139   my $rl = Term::ReadLine->new;
 140   my $tcl = $self->tcl;
 141   my $cmd;
 142
 143   while (defined(my $line = $rl->readline(length($cmd)?'> ':'$ '))) {
 144     $cmd .= "${line}\n";
 145     my $out;
 146     if ($tcl->call(info => complete => $cmd)) {
 147       if (eval { $out = $tcl->Eval($cmd); 1 }) {
 148         print $out;
 149         if (length($out) and $out !~ /\n$/) { print "\n" }
 150       } else {
 151         $tcl->Eval(q{puts $::errorInfo});
 152       }
 153       $cmd = '';
 154     }
 155   }
 156 }
 157
 158 1;
 159
 160 __DATA__
 161 namespace eval DX {
 162
 163   variable current_body {}
 164
 165   proc rule {name args body} {
 166     setup_eval_scope
 167     _call add_rule $name $args [expand_body $body]
 168   }
 169
 170   proc query {body {out ""}} {
 171     setup_eval_scope
 172     set res [_call first_result query [expand_body $body]]
 173     return [format_response $res $out]
 174   }
 175
 176   proc query* {body {out ""}} {
 177     setup_eval_scope
 178     set each_res [_call each_result query [expand_body $body]]
 179     if [string length $out] {
 180       set join_by ""
 181     } else {
 182       set join_by "--\n"
 183     }
 184     return [join [lmap res $each_res {format_response $res $out}] $join_by]
 185   }
 186
 187   proc solve {body {out ""}} {
 188     setup_eval_scope
 189     set res [_call first_result solve [expand_body $body]]
 190     return [format_response $res $out]
 191   }
 192
 193   proc ensure {body {out ""}} {
 194     setup_eval_scope
 195     set res [_call ensure_result [expand_body $body]]
 196     return [format_response $res $out]
 197   }
 198
 199   proc format_action {type data} {
 200     set flat "$type ->\n";
 201     append flat [format_response $data "" "  "]
 202     return $flat
 203   }
 204
 205   proc format_response {res out {i ""}} {
 206     if {[llength $res] < 2} {
 207       return "${i}$res\n";
 208     }
 209     if [string length $out] {
 210       return [dict with res $out]
 211     }
 212     set flat ""
 213     if [dict exists $res _actions] {
 214       foreach {n v} [dict get $res _actions] {
 215         append flat [format_action $type $data]
 216       }
 217       append flat "->\n";
 218     }
 219     dict for {k v} $res {
 220       if ![string match _* $k] {
 221         if {[dict exists $res _meta $k is_list]
 222             && [dict get $res _meta $k is_list]} {
 223           append flat "$i$k:\n"
 224           foreach l $v { append flat "$i  $l\n" }
 225         } else {
 226           append flat "$i$k: $v\n"
 227         }
 228       }
 229     }
 230     return $flat
 231   }
 232
 233   proc expand_body body {
 234     variable current_body
 235     set save_body $current_body
 236     set current_body {seq}
 237     namespace eval ::DX::Eval $body
 238     set final_body $current_body
 239     set current_body $save_body
 240     return $final_body
 241   }
 242
 243   proc body_add {name raw_args} {
 244     variable current_body
 245     lappend current_body [concat call $name [::DX::mangle_args $raw_args]]
 246   }
 247
 248   proc setup_eval_scope {} {
 249     set rules [ _call rule_names ];
 250     foreach {name arity} $rules {
 251       if ![llength [info procs ::DX::Eval::$name]] {
 252         namespace inscope ::DX::Eval proc $name args [
 253           concat DX::body_add $name {$args}
 254         ]
 255       }
 256     }
 257   }
 258
 259   proc mangle_arg {arg} {
 260     if [regexp {^'(.*)'$} $arg -> value] {
 261       return [list value $value]
 262     }
 263     if {[llength $arg] > 1} {
 264       return [expand_body $arg]
 265     }
 266     return [list var $arg]
 267   }
 268
 269   proc mangle_args {raw} {
 270     return [lmap x $raw { mangle_arg $x }]
 271   }
 272
 273   proc action_cb args {
 274     _call set_action_cb {*}$args
 275   }
 276
 277   action_cb apply {{n v} {puts [DX::format_action $n $v]}}
 278
 279   namespace eval ::DX::Eval {
 280     proc findall args { DX::body_add findall $args }
 281     proc foreach args { DX::body_add foreach $args }
 282     proc not args { DX::body_add not $args }
 283   }
 284
 285   namespace export rule query query* solve ensure
 286 }