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; |
eed368c9 |
9 | |
10 | my $solver = DX::Solver->new(observation_policy => sub { 1 }); |
11 | |
12 | DX::Lib::FS->new->load_into($solver); |
13 | |
14 | #::Dwarn( |
15 | # [ $solver->query([ 'D' ], [ directory_at => 'D' => \'t' ])->results ] |
16 | # ->[0]->value_for('D') |
17 | #); |
18 | |
19 | use Tcl; |
20 | |
21 | my $tcl = Tcl->new; |
22 | |
23 | my $split = $tcl->curry::weak::SplitList; |
24 | |
25 | my (@res, @last_q); |
26 | |
27 | sub do_query { |
28 | @res = $solver->query(@last_q)->results; |
29 | Dwarn([ map { |
30 | my @act = $_->actions; |
31 | ((@act ? \@act : ()), $_->all_values); |
32 | } @res ]); |
33 | } |
34 | |
a26f6378 |
35 | sub expand_def { |
36 | my ($vars, $body) = @_; |
eed368c9 |
37 | my @varnames = $split->($vars); |
97c0c46e |
38 | return (\@varnames, expand_body($body)); |
39 | } |
40 | |
41 | sub expand_body { |
42 | my ($body) = @_; |
eed368c9 |
43 | local our @Body_Parts; |
44 | $tcl->Eval($body); |
97c0c46e |
45 | return @Body_Parts; |
a26f6378 |
46 | } |
47 | |
48 | $tcl->CreateCommand(query => sub { |
49 | my (undef, undef, undef, $vars, $body) = @_; |
50 | @last_q = expand_def($vars, $body); |
eed368c9 |
51 | do_query(); |
52 | return; |
53 | }); |
54 | |
55 | $tcl->CreateCommand(run => sub { |
56 | foreach my $ind ($res[0]->independent_actions) { |
57 | my $cl = ref($ind); |
58 | warn +(split('::', $cl))[-1]."\n"; |
59 | $solver->run_action($ind); |
60 | } |
61 | do_query(); |
62 | return; |
63 | }); |
64 | |
65 | sub mangle_args { |
66 | my @args = @_; |
67 | map { $_ =~ /^'(.*)'$/ ? \do { my $x = $1 } : $_ } @args; |
68 | } |
69 | |
70 | my $rule_sub = sub { |
71 | my (undef, undef, $name, @args) = @_; |
72 | push our @Body_Parts, [ $name => mangle_args(@args) ]; |
73 | return; |
74 | }; |
75 | |
a26f6378 |
76 | $tcl->CreateCommand(rule => sub { |
77 | my (undef, undef, undef, $rule, $vars, $body) = @_; |
78 | $solver->add_rule($rule => expand_def($vars, $body)); |
79 | $tcl->CreateCommand($rule => $rule_sub); |
80 | return; |
81 | }); |
82 | |
eed368c9 |
83 | foreach my $rule (keys %{$solver->rule_set->rules}) { |
84 | $rule =~ s/\/\d+$//; |
85 | $tcl->CreateCommand($rule => $rule_sub); |
86 | } |
a26f6378 |
87 | |
88 | $tcl->CreateCommand(exists => sub { |
89 | my (undef, undef, undef, $vars, $body) = @_; |
90 | push our @Body_Parts, [ exists => expand_def($vars, $body) ]; |
91 | return; |
92 | }); |
97c0c46e |
93 | |
94 | $tcl->CreateCommand(foreach => sub { |
95 | my (undef, undef, undef, $var, $body, $each_body) = @_; |
96 | push our @Body_Parts, [ |
97 | foreach => $var => map [ expand_body($_) ], $body, $each_body |
98 | ]; |
99 | return; |
100 | }); |
eed368c9 |
101 | |
102 | #$tcl->Eval(q{query D {directory_at D 't'; mode D '0755'; }}); |
103 | |
a26f6378 |
104 | if ($ARGV[0]) { |
105 | $tcl->EvalFile($ARGV[0]); |
106 | } |
107 | |
eed368c9 |
108 | my $rl = Term::ReadLine->new; |
109 | |
110 | my $cmd; |
111 | |
2e60bb64 |
112 | while (defined(my $line = $rl->readline(length($cmd)?'> ':'$ '))) { |
113 | $cmd .= "${line}\n"; |
eed368c9 |
114 | if ($tcl->call(info => complete => $cmd)) { |
a57a26e3 |
115 | unless (eval { $tcl->Eval($cmd); 1 }) { |
116 | warn $@; |
117 | } |
eed368c9 |
118 | $cmd = ''; |
119 | } |
120 | } |