add rule and exists built-ins to shell

[scpubgit/DKit.git] / bin / dx-shell

#!/usr/bin/env perl

use strictures 1;
use curry;
use DX::Solver;
use DX::Lib::FS;
use Term::ReadLine;
use Devel::Dwarn;

my $solver = DX::Solver->new(observation_policy => sub { 1 });

DX::Lib::FS->new->load_into($solver);

#::Dwarn(
#  [ $solver->query([ 'D' ], [ directory_at => 'D' => \'t' ])->results ]
#    ->[0]->value_for('D')
#);

use Tcl;

my $tcl = Tcl->new;

my $split = $tcl->curry::weak::SplitList;

my (@res, @last_q);

sub do_query {
  @res = $solver->query(@last_q)->results;
  Dwarn([ map {
    my @act = $_->actions;
    ((@act ? \@act : ()), $_->all_values);
  } @res ]);
}

sub expand_def {
  my ($vars, $body) = @_;
  my @varnames = $split->($vars);
  local our @Body_Parts;
  $tcl->Eval($body);
  return (\@varnames, @Body_Parts);
}

$tcl->CreateCommand(query => sub {
  my (undef, undef, undef, $vars, $body) = @_;
  @last_q = expand_def($vars, $body);
  do_query();
  return;
});

$tcl->CreateCommand(run => sub {
  foreach my $ind ($res[0]->independent_actions) {
    my $cl = ref($ind);
    warn +(split('::', $cl))[-1]."\n";
    $solver->run_action($ind);
  }
  do_query();
  return;
});

sub mangle_args {
  my @args = @_;
  map { $_ =~ /^'(.*)'$/ ? \do { my $x = $1 } : $_ } @args;
}

my $rule_sub = sub {
  my (undef, undef, $name, @args) = @_;
  push our @Body_Parts, [ $name => mangle_args(@args) ];
  return;
};

$tcl->CreateCommand(rule => sub {
  my (undef, undef, undef, $rule, $vars, $body) = @_;
  $solver->add_rule($rule => expand_def($vars, $body));
  $tcl->CreateCommand($rule => $rule_sub);
  return;
});

foreach my $rule (keys %{$solver->rule_set->rules}) {
  $rule =~ s/\/\d+$//;
  $tcl->CreateCommand($rule => $rule_sub);
}

$tcl->CreateCommand(exists => sub {
  my (undef, undef, undef, $vars, $body) = @_;
  push our @Body_Parts, [ exists => expand_def($vars, $body) ];
  return;
});
  
#$tcl->Eval(q{query D {directory_at D 't'; mode D '0755'; }});

if ($ARGV[0]) {
  $tcl->EvalFile($ARGV[0]);
}

my $rl = Term::ReadLine->new;

my $cmd;

while (defined(my $line = $rl->readline(length($cmd)?'> ':'$ '))) {
  $cmd .= "${line}\n";
  if ($tcl->call(info => complete => $cmd)) {
    $tcl->Eval($cmd);
    $cmd = '';
  }
}