bin/dx-shell

   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;
   8 use Devel::Dwarn;
   9 use Sub::Quote;
  10
  11 my $solver = DX::Solver->new(observation_policy => sub { 1 });
  12
  13 DX::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
  20 use Tcl;
  21
  22 my $tcl = Tcl->new;
  23
  24 my $split = $tcl->curry::weak::SplitList;
  25
  26 my ($r, $res, @last_q);
  27
  28 my $last_mode;
  29
  30 sub show {
  31   $r = ($res->isa('DX::Result') ? $res : $res->next);
  32   unless ($r) { warn "false\n"; return; }
  33   Dwarn(map {
  34     my @act = $_->actions;
  35     ((@act ? \@act : ()), $_->all_values);
  36   } $r);
  37 }
  38
  39 sub do_query {
  40   $res = $solver->$last_mode(@last_q);
  41   show();
  42 }
  43
  44 sub expand_def {
  45   my ($vars, $body) = @_;
  46   my @varnames = $split->($vars);
  47   return (\@varnames, expand_body($body));
  48 }
  49
  50 sub expand_body {
  51   my (@body) = @_;
  52   local our @Body_Parts;
  53   $tcl->Eval(@body);
  54   return @Body_Parts;
  55 }
  56
  57 sub q_command {
  58   my ($this_mode, undef, undef, undef, $body) = @_;
  59   $last_mode = $this_mode;
  60   if ($body) {
  61     @last_q = expand_body($body);
  62   }
  63   do_query();
  64   return;
  65 }
  66
  67 $tcl->CreateCommand('?' => sub { q_command(query => @_) });
  68 $tcl->CreateCommand('?!' => sub { q_command(solve => @_) });
  69 $tcl->CreateCommand('!?' => sub { q_command(solve => @_) });
  70 $tcl->CreateCommand('!' => sub { q_command(ensure => @_) });
  71
  72 $tcl->CreateCommand(run => sub {
  73   foreach my $ind ($r->independent_actions) {
  74     $solver->run_action($ind);
  75   }
  76   do_query();
  77   return;
  78 });
  79
  80 $tcl->CreateCommand(dump => sub {
  81   my (undef, undef, undef, $to_dump) = @_;
  82   my $filter = quote_sub($to_dump);
  83   Dwarn($filter->($r));
  84 });
  85
  86 sub mangle_args {
  87   my @args = @_;
  88   map { $_ =~ /^'(.*)'$/ ? \do { my $x = $1 } : $_ } @args;
  89 }
  90
  91 my $rule_sub = sub {
  92   my (undef, undef, $name, @args) = @_;
  93   push our @Body_Parts, [ $name => mangle_args(@args) ];
  94   return;
  95 };
  96
  97 $tcl->CreateCommand(rule => sub {
  98   my (undef, undef, undef, $rule, $vars, $body) = @_;
  99   $solver->add_rule($rule => expand_def($vars, $body));
 100   $tcl->CreateCommand($rule => $rule_sub);
 101   return;
 102 });
 103
 104 foreach my $rule (keys %{$solver->rule_set->rules}) {
 105   $rule =~ s/\/\d+$//;
 106   $tcl->CreateCommand($rule => $rule_sub);
 107 }
 108
 109 $tcl->CreateCommand(foreach => sub {
 110   my (undef, undef, undef, $var, $body, $each_body) = @_;
 111   push our @Body_Parts, [
 112     foreach => $var => map [ expand_body($_) ], $body, $each_body
 113   ];
 114   return;
 115 });
 116
 117 $tcl->CreateCommand(findall => sub {
 118   my (undef, undef, undef, $coll_var, $name_var, $body) = @_;
 119   push our @Body_Parts, [
 120     findall => $coll_var => $name_var => expand_body($body)
 121   ];
 122   return;
 123 });
 124
 125 #$tcl->Eval(q{query D {directory_at D 't'; mode D '0755'; }});
 126
 127 if ($ARGV[0]) {
 128   $tcl->EvalFile($ARGV[0]);
 129 }
 130
 131 my $rl = Term::ReadLine->new;
 132
 133 my $cmd;
 134
 135 while (defined(my $line = $rl->readline(length($cmd)?'> ':'$ '))) {
 136   $cmd .= "${line}\n";
 137   if ($tcl->call(info => complete => $cmd)) {
 138     unless (eval { $tcl->Eval($cmd); 1 }) {
 139       warn $@;
 140     }
 141     $cmd = '';
 142   }
 143 }