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   die "No body!" unless $body;
  64   local our @Body_Parts;
  65   $tcl->Eval($body);
  66   return @Body_Parts;
  67 }
  68
  69 sub q_command {
  70   my ($this_mode, undef, undef, undef, $body) = @_;
  71   $last_mode = $this_mode;
  72   if ($body) {
  73     @last_q = expand_body($body);
  74   }
  75   do_query();
  76   return;
  77 }
  78
  79 $tcl->CreateCommand('?' => sub { q_command(query => @_) });
  80 $tcl->CreateCommand('?!' => sub { q_command(solve => @_) });
  81 $tcl->CreateCommand('!?' => sub { q_command(solve => @_) });
  82 $tcl->CreateCommand('!' => sub { q_command(ensure => @_) });
  83
  84 $tcl->CreateCommand(run => sub {
  85   foreach my $ind ($r->independent_actions) {
  86     $solver->run_action($ind);
  87   }
  88   do_query();
  89   return;
  90 });
  91
  92 $tcl->CreateCommand(dump => sub {
  93   my (undef, undef, undef, $to_dump) = @_;
  94   my $filter = quote_sub($to_dump);
  95   Dwarn($filter->($r));
  96 });
  97
  98 sub mangle_args {
  99   my @args = @_;
 100   map { $_ =~ /^'(.*)'$/ ? \do { my $x = $1 } : $_ } @args;
 101 }
 102
 103 my $rule_sub = sub {
 104   my (undef, undef, $name, @args) = @_;
 105   push our @Body_Parts, [ $name => mangle_args(@args) ];
 106   return;
 107 };
 108
 109 $tcl->CreateCommand(rule => sub {
 110   my (undef, undef, undef, $rule, $vars, $body) = @_;
 111   $solver->add_rule($rule => expand_def($vars, $body));
 112   $tcl->CreateCommand($rule => $rule_sub);
 113   return;
 114 });
 115
 116 foreach my $rule (keys %{$solver->rule_set->rules}) {
 117   $rule =~ s/\/\d+$//;
 118   $tcl->CreateCommand($rule => $rule_sub);
 119 }
 120
 121 $tcl->CreateCommand(foreach => sub {
 122   my (undef, undef, undef, $var, $body, $each_body) = @_;
 123   push our @Body_Parts, [
 124     foreach => $var => map [ expand_body($_) ], $body, $each_body
 125   ];
 126   return;
 127 });
 128
 129 $tcl->CreateCommand(findall => sub {
 130   my (undef, undef, undef, $coll_var, $name_var, $body) = @_;
 131   push our @Body_Parts, [
 132     findall => $coll_var => $name_var => expand_body($body)
 133   ];
 134   return;
 135 });
 136
 137 $tcl->CreateCommand(not => sub {
 138   my (undef, undef, undef, $body) = @_;
 139   push our @Body_Parts, [ not => expand_body($body) ];
 140   return;
 141 });
 142
 143 $tcl->CreateCommand(n => \&show);
 144
 145 #$tcl->Eval(q{query D {directory_at D 't'; mode D '0755'; }});
 146
 147 if ($ARGV[0]) {
 148   $tcl->EvalFile($ARGV[0]);
 149 }
 150
 151 my $rl = Term::ReadLine->new;
 152
 153 my $cmd;
 154
 155 while (defined(my $line = $rl->readline(length($cmd)?'> ':'$ '))) {
 156   $cmd .= "${line}\n";
 157   if ($tcl->call(info => complete => $cmd)) {
 158     unless (eval { $tcl->Eval($cmd); 1 }) {
 159       warn $@;
 160     }
 161     $cmd = '';
 162   }
 163 }