Commit | Line | Data |
91d1f239 |
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 | |
e28f7460 |
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 | |
91d1f239 |
83 | sub _implode_result { |
84 | my ($self, $result) = @_; |
85 | my $imploded = $self->_implode_hashref($result->all_values); |
86 | if (my @act = $result->actions) { |
e28f7460 |
87 | my @flat_act = map $self->_implode_action, @act; |
91d1f239 |
88 | unshift @$imploded, +(_actions => \@flat_act); |
89 | } |
90 | return $imploded; |
91 | } |
92 | |
e28f7460 |
93 | sub _implode_action { |
94 | my ($self, $action) = @_; |
95 | map +($_->[0], $self->_implode_hashref($_->[1])), [ %{$action->as_structure} ]; |
96 | } |
97 | |
91d1f239 |
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 | |
e28f7460 |
199 | proc format_action {type data} { |
200 | set flat "$type ->\n"; |
201 | append flat [format_response $data "" " "] |
202 | return $flat |
203 | } |
204 | |
91d1f239 |
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] { |
e28f7460 |
215 | append flat [format_action $type $data] |
91d1f239 |
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 | |
e28f7460 |
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 | |
91d1f239 |
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 | } |