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 (@res, @last_q);
  27
  28 sub 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
  36 sub expand_def {
  37   my ($vars, $body) = @_;
  38   my @varnames = $split->($vars);
  39   return (\@varnames, expand_body($body));
  40 }
  41
  42 sub expand_body {
  43   my ($body) = @_;
  44   local our @Body_Parts;
  45   $tcl->Eval($body);
  46   return @Body_Parts;
  47 }
  48
  49 $tcl->CreateCommand(query => sub {
  50   my (undef, undef, undef, $body) = @_;
  51   @last_q = expand_body($body);
  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
  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
  72 sub mangle_args {
  73   my @args = @_;
  74   map { $_ =~ /^'(.*)'$/ ? \do { my $x = $1 } : $_ } @args;
  75 }
  76
  77 my $rule_sub = sub {
  78   my (undef, undef, $name, @args) = @_;
  79   push our @Body_Parts, [ $name => mangle_args(@args) ];
  80   return;
  81 };
  82
  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
  90 foreach my $rule (keys %{$solver->rule_set->rules}) {
  91   $rule =~ s/\/\d+$//;
  92   $tcl->CreateCommand($rule => $rule_sub);
  93 }
  94
  95 $tcl->CreateCommand(foreach => sub {
  96   my (undef, undef, undef, $var, $body, $each_body) = @_;
  97   push our @Body_Parts, [
  98     foreach => $var => map [ expand_body($_) ], $body, $each_body
  99   ];
 100   return;
 101 });
 102
 103 #$tcl->Eval(q{query D {directory_at D 't'; mode D '0755'; }});
 104
 105 if ($ARGV[0]) {
 106   $tcl->EvalFile($ARGV[0]);
 107 }
 108
 109 my $rl = Term::ReadLine->new;
 110
 111 my $cmd;
 112
 113 while (defined(my $line = $rl->readline(length($cmd)?'> ':'$ '))) {
 114   $cmd .= "${line}\n";
 115   if ($tcl->call(info => complete => $cmd)) {
 116     unless (eval { $tcl->Eval($cmd); 1 }) {
 117       warn $@;
 118     }
 119     $cmd = '';
 120   }
 121 }