add support for not rules

[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;
use Sub::Quote;
use YAML ();
use Safe::Isa;

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 ($r, $res, @last_q);

my $last_mode;

sub show {
  $r = ($res->isa('DX::Result') ? $res : $res->next);
  unless ($r) { warn "false\n"; return; }
  if (my @act = $r->actions) {
    warn YAML::Dump([ map $_->as_structure, @act ]);
  }
  my $values = $r->all_values;
  unless (keys %$values) {
    warn "---\ntrue\n"; return;
  }
  warn YAML::Dump({
    map +($_ => ($values->{$_}->$_does('DX::Role::Set')
                  ? [ $values->{$_}->all ]
                  : $values->{$_} )),
      keys %$values
  });
}

sub do_query {
  $res = $solver->$last_mode(@last_q);
  show();
}

sub expand_def {
  my ($vars, $body) = @_;
  my @varnames = $split->($vars);
  return (\@varnames, expand_body($body));
}

sub expand_body {
  my ($body) = @_;
  die "No body!" unless $body;
  local our @Body_Parts;
  $tcl->Eval($body);
  return @Body_Parts;
}

sub q_command {
  my ($this_mode, undef, undef, undef, $body) = @_;
  $last_mode = $this_mode;
  if ($body) {
    @last_q = expand_body($body);
  }
  do_query();
  return;
}

$tcl->CreateCommand('?' => sub { q_command(query => @_) });
$tcl->CreateCommand('?!' => sub { q_command(solve => @_) });
$tcl->CreateCommand('!?' => sub { q_command(solve => @_) });
$tcl->CreateCommand('!' => sub { q_command(ensure => @_) });

$tcl->CreateCommand(run => sub {
  foreach my $ind ($r->independent_actions) {
    $solver->run_action($ind);
  }
  do_query();
  return;
});

$tcl->CreateCommand(dump => sub {
  my (undef, undef, undef, $to_dump) = @_;
  my $filter = quote_sub($to_dump);
  Dwarn($filter->($r));
});

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(foreach => sub {
  my (undef, undef, undef, $var, $body, $each_body) = @_;
  push our @Body_Parts, [
    foreach => $var => map [ expand_body($_) ], $body, $each_body
  ];
  return;
});

$tcl->CreateCommand(findall => sub {
  my (undef, undef, undef, $coll_var, $name_var, $body) = @_;
  push our @Body_Parts, [
    findall => $coll_var => $name_var => expand_body($body)
  ];
  return;
});

$tcl->CreateCommand(not => sub {
  my (undef, undef, undef, $body) = @_;
  push our @Body_Parts, [ not => expand_body($body) ];
  return;
});

$tcl->CreateCommand(n => \&show);
  
#$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)) {
    unless (eval { $tcl->Eval($cmd); 1 }) {
      warn $@;
    }
    $cmd = '';
  }
}