KeyMangler example app

[scpubgit/DKit.git] / lib / DX / Tcl.pm

package DX::Tcl;

use strictures 1;
use curry;
use DX::Solver;
use DX::Lib::FS;
use Term::ReadLine;
use Devel::Dwarn;
use Tcl;
use Safe::Isa;
use Moo;

has solver => (is => 'lazy', builder => sub {
  my $solver = DX::Solver->new(observation_policy => sub { 1 });
  DX::Lib::FS->new->load_into($solver);
  $solver;
});

has tcl => (is => 'lazy', builder => sub {
  my ($self) = @_;
  my $tcl = Tcl->new;
  $tcl->CreateCommand('DX::_call' => $self->curry::weak::handle_tcl_call);
  our $Tcl_Data ||= do { local $/; my $data = <DATA>; close(DATA); $data };
  $tcl->Eval($Tcl_Data);
  $tcl->call(namespace => import => 'DX::*');
  return $tcl;
});

sub handle_tcl_call {
  my ($self, undef, undef, undef, $call, @args) = @_;
  return $self->${\"_tcl_${call}"}(@args);
  #Dwarn(\@stuff);
  return 1;
}

sub _tcl_rule_names {
  my ($self) = @_;
  return [ map /(.*)\/(\d+)/, keys %{$self->solver->rule_set->rules} ];
}

sub _tcl_add_rule {
  my ($self, $name, $args, $raw_body) = @_;
  my @args = $self->tcl->SplitList($args);
  #warn $raw_body;
  my $body = $self->_expand_tcl_data($raw_body);
  #Dwarn([ $name, \@args, @$body ]);
  $self->solver->add_rule($name => \@args => @$body);
  return;
}

sub _tcl_first_result {
  my ($self, $type, $raw_query) = @_;
  my $query = $self->_expand_tcl_data($raw_query);
  my $rs = $self->solver->$type(@$query);
  my $result = $rs->next;
  return $result ? $self->_implode_result($result) : 'false';
}

sub _tcl_each_result {
  my ($self, $type, $raw_query) = @_;
  my $query = $self->_expand_tcl_data($raw_query);
  my $rs = $self->solver->$type(@$query);
  return [ map $self->_implode_result($_), $rs->results ];
}

sub _tcl_ensure_result {
  my ($self, $raw_query) = @_;
  my $query = $self->_expand_tcl_data($raw_query);
  my $result = $self->solver->ensure(@$query);
  return $result ? $self->_implode_result($result) : 'false';
}

sub _implode_result {
  my ($self, $result) = @_;
  my $imploded = $self->_implode_hashref($result->all_values);
  if (my @act = $result->actions) {
    my @flat_act = map +($_->[0], $self->_implode_hashref($_->[1])),
                     map [ %{$_->as_structure} ], @act;
    unshift @$imploded, +(_actions => \@flat_act);
  }
  return $imploded;
}

sub _implode_hashref {
  my ($self, $values) = @_;
  my @flat;
  my %meta;
  foreach my $key (sort keys %$values) {
    my $v = $values->{$key};
    if ($v->$_does('DX::Role::Set')) {
      $meta{$key}{is_list} = 1;
      push @flat, ($key => [ map "$_", $v->all ]);
    } elsif (ref($v) and ref($v) eq 'ARRAY') {
      $meta{$key}{is_list} = 1;
      push @flat, ($key => [ map "$_", @$v ]);
    } else {
      push @flat, ($key => "$v");
    }
  }
  my @flat_meta = map +($_ => [ %{$meta{$_}} ]), sort keys %meta;
  return [ (@flat_meta ? (_meta => \@flat_meta) : ()), @flat ];
}

sub _expand_tcl_data {
  my ($self, $data) = @_;
  my ($type, @rest) = $self->tcl->SplitList($data);
  die "No type" unless $type;
  if ($type eq 'seq') {
    return [ map $self->_expand_tcl_data($_), @rest ];
  } elsif ($type eq 'call') {
    my ($name, @args) = @rest;
    return [ $name => map $self->_expand_tcl_data($_), @args ];
  } elsif ($type eq 'var') {
    return $rest[0];
  } elsif ($type eq 'value') {
    return \$rest[0]
  }
  die "Unknown type ${type}";
}

sub run { shift->repl }

sub repl {
  my ($self) = @_;
  my $rl = Term::ReadLine->new;
  my $tcl = $self->tcl;
  my $cmd;

  while (defined(my $line = $rl->readline(length($cmd)?'> ':'$ '))) {
    $cmd .= "${line}\n";
    my $out;
    if ($tcl->call(info => complete => $cmd)) {
      if (eval { $out = $tcl->Eval($cmd); 1 }) {
        print $out;
        if (length($out) and $out !~ /\n$/) { print "\n" }
      } else {
        $tcl->Eval(q{puts $::errorInfo});
      }
      $cmd = '';
    }
  }
}

1;

__DATA__
namespace eval DX {

  variable current_body {}

  proc rule {name args body} {
    setup_eval_scope
    _call add_rule $name $args [expand_body $body]
  }

  proc query {body {out ""}} {
    setup_eval_scope
    set res [_call first_result query [expand_body $body]]
    return [format_response $res $out]
  }

  proc query* {body {out ""}} {
    setup_eval_scope
    set each_res [_call each_result query [expand_body $body]]
    if [string length $out] {
      set join_by ""
    } else {
      set join_by "--\n"
    }
    return [join [lmap res $each_res {format_response $res $out}] $join_by]
  }

  proc solve {body {out ""}} {
    setup_eval_scope
    set res [_call first_result solve [expand_body $body]]
    return [format_response $res $out]
  }

  proc ensure {body {out ""}} {
    setup_eval_scope
    set res [_call ensure_result [expand_body $body]]
    return [format_response $res $out]
  }

  proc format_response {res out {i ""}} {
    if {[llength $res] < 2} {
      return "${i}$res\n";
    }
    if [string length $out] {
      return [dict with res $out]
    }
    set flat ""
    if [dict exists $res _actions] {
      foreach {n v} [dict get $res _actions] {
        append flat "$n -> \n";
        append flat [format_response $v "" "  "]
      }
      append flat "->\n";
    }
    dict for {k v} $res {
      if ![string match _* $k] {
        if {[dict exists $res _meta $k is_list]
            && [dict get $res _meta $k is_list]} {
          append flat "$i$k:\n"
          foreach l $v { append flat "$i  $l\n" }
        } else {
          append flat "$i$k: $v\n"
        }
      }
    }
    return $flat
  }

  proc expand_body body {
    variable current_body
    set save_body $current_body
    set current_body {seq}
    namespace eval ::DX::Eval $body
    set final_body $current_body
    set current_body $save_body
    return $final_body
  }

  proc body_add {name raw_args} {
    variable current_body
    lappend current_body [concat call $name [::DX::mangle_args $raw_args]]
  }

  proc setup_eval_scope {} {
    set rules [ _call rule_names ];
    foreach {name arity} $rules {
      if ![llength [info procs ::DX::Eval::$name]] {
        namespace inscope ::DX::Eval proc $name args [
          concat DX::body_add $name {$args}
        ]
      }
    }
  }

  proc mangle_arg {arg} {
    if [regexp {^'(.*)'$} $arg -> value] {
      return [list value $value]
    }
    if {[llength $arg] > 1} {
      return [expand_body $arg]
    }
    return [list var $arg]
  }

  proc mangle_args {raw} {
    return [lmap x $raw { mangle_arg $x }]
  }

  namespace eval ::DX::Eval {
    proc findall args { DX::body_add findall $args }
    proc foreach args { DX::body_add foreach $args }
    proc not args { DX::body_add not $args }
  }

  namespace export rule query query* solve ensure
}