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 use YAML ();
  11 use Safe::Isa;
  12
  13 my $solver = DX::Solver->new(observation_policy => sub { 1 });
  14
  15 DX::Lib::FS->new->load_into($solver);
  16
  17 #::Dwarn(
  18 #  [ $solver->query([ 'D' ], [ directory_at => 'D' => \'t' ])->results ]
  19 #    ->[0]->value_for('D')
  20 #);
  21
  22 use Tcl;
  23
  24 my $tcl = Tcl->new;
  25
  26 my $split = $tcl->curry::weak::SplitList;
  27
  28 my ($r, $res, @last_q);
  29
  30 my $last_mode;
  31
  32 sub show {
  33   $r = ($res->isa('DX::Result') ? $res : $res->next);
  34   unless ($r) { warn "false\n"; return; }
  35   if (my @act = $r->actions) {
  36     warn YAML::Dump([ map $_->as_structure, @act ]);
  37   }
  38   my $values = $r->all_values;
  39   unless (keys %$values) {
  40     warn "---\ntrue\n"; return;
  41   }
  42   warn YAML::Dump({
  43     map +($_ => ($values->{$_}->$_does('DX::Role::Set')
  44                   ? [ $values->{$_}->all ]
  45                   : $values->{$_} )),
  46       keys %$values
  47   });
  48 }
  49
  50 sub do_query {
  51   $res = $solver->$last_mode(@last_q);
  52   show();
  53 }
  54
  55 sub expand_def {
  56   my ($vars, $body) = @_;
  57   my @varnames = $split->($vars);
  58   return (\@varnames, expand_body($body));
  59 }
  60
  61 sub expand_body {
  62   my (@body) = @_;
  63   local our @Body_Parts;
  64   $tcl->Eval(@body);
  65   return @Body_Parts;
  66 }
  67
  68 sub q_command {
  69   my ($this_mode, undef, undef, undef, $body) = @_;
  70   $last_mode = $this_mode;
  71   if ($body) {
  72     @last_q = expand_body($body);
  73   }
  74   do_query();
  75   return;
  76 }
  77
  78 $tcl->CreateCommand('?' => sub { q_command(query => @_) });
  79 $tcl->CreateCommand('?!' => sub { q_command(solve => @_) });
  80 $tcl->CreateCommand('!?' => sub { q_command(solve => @_) });
  81 $tcl->CreateCommand('!' => sub { q_command(ensure => @_) });
  82
  83 $tcl->CreateCommand(run => sub {
  84   foreach my $ind ($r->independent_actions) {
  85     $solver->run_action($ind);
  86   }
  87   do_query();
  88   return;
  89 });
  90
  91 $tcl->CreateCommand(dump => sub {
  92   my (undef, undef, undef, $to_dump) = @_;
  93   my $filter = quote_sub($to_dump);
  94   Dwarn($filter->($r));
  95 });
  96
  97 sub mangle_args {
  98   my @args = @_;
  99   map { $_ =~ /^'(.*)'$/ ? \do { my $x = $1 } : $_ } @args;
 100 }
 101
 102 my $rule_sub = sub {
 103   my (undef, undef, $name, @args) = @_;
 104   push our @Body_Parts, [ $name => mangle_args(@args) ];
 105   return;
 106 };
 107
 108 $tcl->CreateCommand(rule => sub {
 109   my (undef, undef, undef, $rule, $vars, $body) = @_;
 110   $solver->add_rule($rule => expand_def($vars, $body));
 111   $tcl->CreateCommand($rule => $rule_sub);
 112   return;
 113 });
 114
 115 foreach my $rule (keys %{$solver->rule_set->rules}) {
 116   $rule =~ s/\/\d+$//;
 117   $tcl->CreateCommand($rule => $rule_sub);
 118 }
 119
 120 $tcl->CreateCommand(foreach => sub {
 121   my (undef, undef, undef, $var, $body, $each_body) = @_;
 122   push our @Body_Parts, [
 123     foreach => $var => map [ expand_body($_) ], $body, $each_body
 124   ];
 125   return;
 126 });
 127
 128 $tcl->CreateCommand(findall => sub {
 129   my (undef, undef, undef, $coll_var, $name_var, $body) = @_;
 130   push our @Body_Parts, [
 131     findall => $coll_var => $name_var => expand_body($body)
 132   ];
 133   return;
 134 });
 135
 136 $tcl->CreateCommand(n => \&show);
 137
 138 #$tcl->Eval(q{query D {directory_at D 't'; mode D '0755'; }});
 139
 140 if ($ARGV[0]) {
 141   $tcl->EvalFile($ARGV[0]);
 142 }
 143
 144 my $rl = Term::ReadLine->new;
 145
 146 my $cmd;
 147
 148 while (defined(my $line = $rl->readline(length($cmd)?'> ':'$ '))) {
 149   $cmd .= "${line}\n";
 150   if ($tcl->call(info => complete => $cmd)) {
 151     unless (eval { $tcl->Eval($cmd); 1 }) {
 152       warn $@;
 153     }
 154     $cmd = '';
 155   }
 156 }