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);
19 has tcl => (is => 'lazy', builder => sub {
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::*');
30 my ($self, undef, undef, undef, $call, @args) = @_;
31 return $self->${\"_tcl_${call}"}(@args);
38 return [ map /(.*)\/(\d+)/, keys %{$self->solver->rule_set->rules} ];
42 my ($self, $name, $args, $raw_body) = @_;
43 my @args = $self->tcl->SplitList($args);
45 my $body = $self->_expand_tcl_data($raw_body);
46 #Dwarn([ $name, \@args, @$body ]);
47 $self->solver->add_rule($name => \@args => @$body);
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';
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 ];
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';
73 sub _tcl_set_action_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]));
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);
94 my ($self, $action) = @_;
95 map +($_->[0], $self->_implode_hashref($_->[1])), [ %{$action->as_structure} ];
98 sub _implode_hashref {
99 my ($self, $values) = @_;
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 ]);
111 push @flat, ($key => "$v");
114 my @flat_meta = map +($_ => [ %{$meta{$_}} ]), sort keys %meta;
115 return [ (@flat_meta ? (_meta => \@flat_meta) : ()), @flat ];
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') {
129 } elsif ($type eq 'value') {
132 die "Unknown type ${type}";
135 sub run { shift->repl }
139 my $rl = Term::ReadLine->new;
140 my $tcl = $self->tcl;
143 while (defined(my $line = $rl->readline(length($cmd)?'> ':'$ '))) {
146 if ($tcl->call(info => complete => $cmd)) {
147 if (eval { $out = $tcl->Eval($cmd); 1 }) {
149 if (length($out) and $out !~ /\n$/) { print "\n" }
151 $tcl->Eval(q{puts $::errorInfo});
163 variable current_body {}
165 proc rule {name args body} {
167 _call add_rule $name $args [expand_body $body]
170 proc query {body {out ""}} {
172 set res [_call first_result query [expand_body $body]]
173 return [format_response $res $out]
176 proc query* {body {out ""}} {
178 set each_res [_call each_result query [expand_body $body]]
179 if [string length $out] {
184 return [join [lmap res $each_res {format_response $res $out}] $join_by]
187 proc solve {body {out ""}} {
189 set res [_call first_result solve [expand_body $body]]
190 return [format_response $res $out]
193 proc ensure {body {out ""}} {
195 set res [_call ensure_result [expand_body $body]]
196 return [format_response $res $out]
199 proc format_action {type data} {
200 set flat "$type ->\n";
201 append flat [format_response $data "" " "]
205 proc format_response {res out {i ""}} {
206 if {[llength $res] < 2} {
209 if [string length $out] {
210 return [dict with res $out]
213 if [dict exists $res _actions] {
214 foreach {n v} [dict get $res _actions] {
215 append flat [format_action $type $data]
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" }
226 append flat "$i$k: $v\n"
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
243 proc body_add {name raw_args} {
244 variable current_body
245 lappend current_body [concat call $name [::DX::mangle_args $raw_args]]
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}
259 proc mangle_arg {arg} {
260 if [regexp {^'(.*)'$} $arg -> value] {
261 return [list value $value]
263 if {[llength $arg] > 1} {
264 return [expand_body $arg]
266 return [list var $arg]
269 proc mangle_args {raw} {
270 return [lmap x $raw { mangle_arg $x }]
273 proc action_cb args {
274 _call set_action_cb {*}$args
277 action_cb apply {{n v} {puts [DX::format_action $n $v]}}
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 }
285 namespace export rule query query* solve ensure