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