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   local our @Body_Parts;
  39   $tcl->Eval($body);
  40   return (\@varnames, @Body_Parts);
  41 }
  42
  43 $tcl->CreateCommand(query => sub {
  44   my (undef, undef, undef, $vars, $body) = @_;
  45   @last_q = expand_def($vars, $body);
  46   do_query();
  47   return;
  48 });
  49
  50 $tcl->CreateCommand(run => sub {
  51   foreach my $ind ($res[0]->independent_actions) {
  52     my $cl = ref($ind);
  53     warn +(split('::', $cl))[-1]."\n";
  54     $solver->run_action($ind);
  55   }
  56   do_query();
  57   return;
  58 });
  59
  60 sub mangle_args {
  61   my @args = @_;
  62   map { $_ =~ /^'(.*)'$/ ? \do { my $x = $1 } : $_ } @args;
  63 }
  64
  65 my $rule_sub = sub {
  66   my (undef, undef, $name, @args) = @_;
  67   push our @Body_Parts, [ $name => mangle_args(@args) ];
  68   return;
  69 };
  70
  71 $tcl->CreateCommand(rule => sub {
  72   my (undef, undef, undef, $rule, $vars, $body) = @_;
  73   $solver->add_rule($rule => expand_def($vars, $body));
  74   $tcl->CreateCommand($rule => $rule_sub);
  75   return;
  76 });
  77
  78 foreach my $rule (keys %{$solver->rule_set->rules}) {
  79   $rule =~ s/\/\d+$//;
  80   $tcl->CreateCommand($rule => $rule_sub);
  81 }
  82
  83 $tcl->CreateCommand(exists => sub {
  84   my (undef, undef, undef, $vars, $body) = @_;
  85   push our @Body_Parts, [ exists => expand_def($vars, $body) ];
  86   return;
  87 });
  88
  89 #$tcl->Eval(q{query D {directory_at D 't'; mode D '0755'; }});
  90
  91 if ($ARGV[0]) {
  92   $tcl->EvalFile($ARGV[0]);
  93 }
  94
  95 my $rl = Term::ReadLine->new;
  96
  97 my $cmd;
  98
  99 while (defined(my $line = $rl->readline(length($cmd)?'> ':'$ '))) {
 100   $cmd .= "${line}\n";
 101   if ($tcl->call(info => complete => $cmd)) {
 102     unless (eval { $tcl->Eval($cmd); 1 }) {
 103       warn $@;
 104     }
 105     $cmd = '';
 106   }
 107 }