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
  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
  35 sub expand_def {
  36   my ($vars, $body) = @_;
  37   my @varnames = $split->($vars);
  38   return (\@varnames, expand_body($body));
  39 }
  40
  41 sub expand_body {
  42   my ($body) = @_;
  43   local our @Body_Parts;
  44   $tcl->Eval($body);
  45   return @Body_Parts;
  46 }
  47
  48 $tcl->CreateCommand(query => sub {
  49   my (undef, undef, undef, $vars, $body) = @_;
  50   @last_q = expand_def($vars, $body);
  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
  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
  83 foreach my $rule (keys %{$solver->rule_set->rules}) {
  84   $rule =~ s/\/\d+$//;
  85   $tcl->CreateCommand($rule => $rule_sub);
  86 }
  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 });
  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 });
 101
 102 #$tcl->Eval(q{query D {directory_at D 't'; mode D '0755'; }});
 103
 104 if ($ARGV[0]) {
 105   $tcl->EvalFile($ARGV[0]);
 106 }
 107
 108 my $rl = Term::ReadLine->new;
 109
 110 my $cmd;
 111
 112 while (defined(my $line = $rl->readline(length($cmd)?'> ':'$ '))) {
 113   $cmd .= "${line}\n";
 114   if ($tcl->call(info => complete => $cmd)) {
 115     unless (eval { $tcl->Eval($cmd); 1 }) {
 116       warn $@;
 117     }
 118     $cmd = '';
 119   }
 120 }