Commit | Line | Data |
eed368c9 |
1 | #!/usr/bin/env perl |
2 | |
3 | use strictures 1; |
4 | use curry; |
5 | use DX::Solver; |
6 | use DX::Lib::FS; |
7 | use Term::ReadLine; |
a26f6378 |
8 | use Devel::Dwarn; |
ffacb8aa |
9 | use Sub::Quote; |
db732a14 |
10 | use YAML (); |
11 | use Safe::Isa; |
eed368c9 |
12 | |
13 | my $solver = DX::Solver->new(observation_policy => sub { 1 }); |
14 | |
15 | DX::Lib::FS->new->load_into($solver); |
16 | |
17 | #::Dwarn( |
18 | # [ $solver->query([ 'D' ], [ directory_at => 'D' => \'t' ])->results ] |
19 | # ->[0]->value_for('D') |
20 | #); |
21 | |
22 | use Tcl; |
23 | |
24 | my $tcl = Tcl->new; |
25 | |
26 | my $split = $tcl->curry::weak::SplitList; |
27 | |
7ca660cb |
28 | my ($r, $res, @last_q); |
eed368c9 |
29 | |
7ca660cb |
30 | my $last_mode; |
31 | |
32 | sub show { |
33 | $r = ($res->isa('DX::Result') ? $res : $res->next); |
34 | unless ($r) { warn "false\n"; return; } |
db732a14 |
35 | if (my @act = $r->actions) { |
36 | warn YAML::Dump([ map $_->as_structure, @act ]); |
37 | } |
38 | my $values = $r->all_values; |
39 | unless (keys %$values) { |
40 | warn "---\ntrue\n"; return; |
41 | } |
42 | warn YAML::Dump({ |
43 | map +($_ => ($values->{$_}->$_does('DX::Role::Set') |
44 | ? [ $values->{$_}->all ] |
45 | : $values->{$_} )), |
46 | keys %$values |
47 | }); |
7ca660cb |
48 | } |
49 | |
50 | sub do_query { |
51 | $res = $solver->$last_mode(@last_q); |
52 | show(); |
eed368c9 |
53 | } |
54 | |
a26f6378 |
55 | sub expand_def { |
56 | my ($vars, $body) = @_; |
eed368c9 |
57 | my @varnames = $split->($vars); |
97c0c46e |
58 | return (\@varnames, expand_body($body)); |
59 | } |
60 | |
61 | sub expand_body { |
cc2be68b |
62 | my ($body) = @_; |
63 | die "No body!" unless $body; |
eed368c9 |
64 | local our @Body_Parts; |
cc2be68b |
65 | $tcl->Eval($body); |
97c0c46e |
66 | return @Body_Parts; |
a26f6378 |
67 | } |
68 | |
7ca660cb |
69 | sub q_command { |
70 | my ($this_mode, undef, undef, undef, $body) = @_; |
71 | $last_mode = $this_mode; |
72 | if ($body) { |
73 | @last_q = expand_body($body); |
74 | } |
eed368c9 |
75 | do_query(); |
76 | return; |
7ca660cb |
77 | } |
78 | |
79 | $tcl->CreateCommand('?' => sub { q_command(query => @_) }); |
80 | $tcl->CreateCommand('?!' => sub { q_command(solve => @_) }); |
81 | $tcl->CreateCommand('!?' => sub { q_command(solve => @_) }); |
82 | $tcl->CreateCommand('!' => sub { q_command(ensure => @_) }); |
eed368c9 |
83 | |
84 | $tcl->CreateCommand(run => sub { |
7ca660cb |
85 | foreach my $ind ($r->independent_actions) { |
eed368c9 |
86 | $solver->run_action($ind); |
87 | } |
88 | do_query(); |
89 | return; |
90 | }); |
91 | |
ffacb8aa |
92 | $tcl->CreateCommand(dump => sub { |
93 | my (undef, undef, undef, $to_dump) = @_; |
94 | my $filter = quote_sub($to_dump); |
7ca660cb |
95 | Dwarn($filter->($r)); |
ffacb8aa |
96 | }); |
97 | |
eed368c9 |
98 | sub mangle_args { |
99 | my @args = @_; |
100 | map { $_ =~ /^'(.*)'$/ ? \do { my $x = $1 } : $_ } @args; |
101 | } |
102 | |
103 | my $rule_sub = sub { |
104 | my (undef, undef, $name, @args) = @_; |
105 | push our @Body_Parts, [ $name => mangle_args(@args) ]; |
106 | return; |
107 | }; |
108 | |
a26f6378 |
109 | $tcl->CreateCommand(rule => sub { |
110 | my (undef, undef, undef, $rule, $vars, $body) = @_; |
111 | $solver->add_rule($rule => expand_def($vars, $body)); |
112 | $tcl->CreateCommand($rule => $rule_sub); |
113 | return; |
114 | }); |
115 | |
eed368c9 |
116 | foreach my $rule (keys %{$solver->rule_set->rules}) { |
117 | $rule =~ s/\/\d+$//; |
118 | $tcl->CreateCommand($rule => $rule_sub); |
119 | } |
a26f6378 |
120 | |
97c0c46e |
121 | $tcl->CreateCommand(foreach => sub { |
122 | my (undef, undef, undef, $var, $body, $each_body) = @_; |
123 | push our @Body_Parts, [ |
124 | foreach => $var => map [ expand_body($_) ], $body, $each_body |
125 | ]; |
126 | return; |
127 | }); |
7ca660cb |
128 | |
129 | $tcl->CreateCommand(findall => sub { |
130 | my (undef, undef, undef, $coll_var, $name_var, $body) = @_; |
131 | push our @Body_Parts, [ |
132 | findall => $coll_var => $name_var => expand_body($body) |
133 | ]; |
134 | return; |
135 | }); |
db732a14 |
136 | |
cc2be68b |
137 | $tcl->CreateCommand(not => sub { |
138 | my (undef, undef, undef, $body) = @_; |
139 | push our @Body_Parts, [ not => expand_body($body) ]; |
140 | return; |
141 | }); |
142 | |
db732a14 |
143 | $tcl->CreateCommand(n => \&show); |
eed368c9 |
144 | |
145 | #$tcl->Eval(q{query D {directory_at D 't'; mode D '0755'; }}); |
146 | |
a26f6378 |
147 | if ($ARGV[0]) { |
148 | $tcl->EvalFile($ARGV[0]); |
149 | } |
150 | |
eed368c9 |
151 | my $rl = Term::ReadLine->new; |
152 | |
153 | my $cmd; |
154 | |
2e60bb64 |
155 | while (defined(my $line = $rl->readline(length($cmd)?'> ':'$ '))) { |
156 | $cmd .= "${line}\n"; |
eed368c9 |
157 | if ($tcl->call(info => complete => $cmd)) { |
a57a26e3 |
158 | unless (eval { $tcl->Eval($cmd); 1 }) { |
159 | warn $@; |
160 | } |
eed368c9 |
161 | $cmd = ''; |
162 | } |
163 | } |