finish adding type constraints

[scpubgit/DX.git] / lib / DX / ShellSession.pm

package DX::ShellSession;

use Tcl;
use Scalar::Util qw(weaken);
use DX::Expander;
use DX::Proposition;
use DX::ActionBuilder::Normal;
use DX::RuleDefinitionContext;
use DX::Utils qw(deparse);
use Types::Standard qw(InstanceOf);
use DX::Class;

has shell_state => (is => 'rwp', required => 1, isa => ShellState);

has expander => (
  is => 'lazy', builder => sub { DX::Expander->new(tcl => $_[0]->tcl) },
  isa => Expander, handles => [ qw(expand_args) ],
);

has tcl => (is => 'lazy', isa => InstanceOf['Tcl'], builder => sub {
  my ($self) = @_;
  weaken $self;
  my $tcl = Tcl->new;
  $tcl->CreateCommand('?' => sub {
    $self->apply_to_state([ 'new_query_state' ], [ mode => 'query' ]);
  });
  $tcl->CreateCommand('?+' => sub {
    $self->apply_to_state([ mode => 'query' ]);
  });
  my $qvars;
  $tcl->CreateCommand('.' => sub {
    $self->apply_to_state([ mode => 'shell' ]);
    $qvars->();
  });
  $tcl->CreateCommand('...' => sub {
    $self->apply_to_state([ mode => 'shell' ]);
    my $orig = my $cur = $self->shell_state->current_query_state;
    while ($cur) {
      $self->_set_shell_state(
        $self->shell_state->but(current_query_state => $cur)
      );
      $qvars->();
      $cur = eval { $cur->with_forced_backtrack };
      push our @Result, [ output => $@ ] if $@;
    }
    $self->_set_shell_state(
      $self->shell_state->but(
        current_query_state => $orig
      ),
    );
    return;
  });
  $tcl->CreateCommand(qlist => sub {
    push our @Result, map [ output => $_ ], @{
      $self->shell_state->current_query_state->proposition_sequence->members
    };
    return;
  });
  $tcl->CreateCommand(qvars => $qvars = sub {
    my $locals = $self->shell_state->current_query_state->search_state
                      ->current_hypothesis->scope->locals->[0];
    push our @Result, [ output => $locals ];
    return;
  });
  $tcl->CreateCommand(qdeps => sub {
    my $rps = $self->shell_state->current_query_state->search_state
                   ->current_hypothesis->resolved_propositions;
    push our @Result, [ output => $rps ];
    return;
  });
  $tcl->CreateCommand(qact => sub {
    my $act = $self->shell_state->current_query_state->search_state
                   ->current_hypothesis->actions;
    push our @Result, map [ output => $_ ], @$act;
    return;
  });
  foreach my $pred (
    keys %{$self->shell_state->template_query_state->predicates}
  ) {
    $tcl->CreateCommand($pred => sub {
      my (undef, undef, undef, @args) = @_; # ($data, $interp, $pred)
      (our $Shell_Context)->apply_predicate($pred => @args);
    });
  }
  $tcl->CreateCommand(const => sub {
    my (undef, undef, undef, $name, $value) = @_;
    my $tqs = $self->shell_state->template_query_state;
    my $new_tqs = $tqs->but(
      globals => $tqs->globals->with_member_at(
        $name => DX::ActionBuilder::Null->new(
                   target_path => [ $name ],
                 )->apply_to_value($self->expand_args($value)),
      ),
    );
    $self->_set_shell_state(
      $self->shell_state->but(
        template_query_state => $new_tqs
      ),
    );
  });
  $tcl->CreateCommand(state => sub {
    my (undef, undef, undef, $name, $value) = @_;
    my $tqs = $self->shell_state->template_query_state;
    my $new_tqs = $tqs->but(
      globals => $tqs->globals->with_member_at(
        $name => DX::ActionBuilder::Normal->new(
                   target_path => [ $name ],
                 )->apply_to_value($self->expand_args($value)),
      ),
    );
    $self->_set_shell_state(
      $self->shell_state->but(
        template_query_state => $new_tqs
      ),
    );
  });
  $tcl->CreateCommand(trace => sub {
    my (undef, undef, undef, @trace) = @_;
    $self->_set_shell_state(
      $self->shell_state->with_trace_changes(@trace)
    );
  });
  $tcl->CreateCommand(rule => sub {
    my (undef, undef, undef, $pred, $args, $body) = @_;
    local our $Shell_Context = DX::RuleDefinitionContext->new(
                                 arg_names => [ $self->tcl->SplitList($args) ],
                                 expander => $self->expander,
                               );
    $self->tcl->Eval($body);
    my $rule = $Shell_Context->bake_rule;
    my $tqs = $self->shell_state->template_query_state;
    my $new_tqs = $tqs->but(
      predicates => {
        %{$tqs->predicates},
        $pred => $rule,
      },
    );
    $self->_set_shell_state(
      $self->shell_state->but(
        template_query_state => $new_tqs
      ),
    );
    $self->tcl->CreateCommand($pred => sub {
      my (undef, undef, undef, @args) = @_; # ($data, $interp, $pred)
      (our $Shell_Context)->apply_predicate($pred => @args);
    });
  });
  return $tcl;
});

sub apply_to_state {
  my ($self, @to_apply) = @_;
  my $state = $self->shell_state;
  our @Result;
  foreach my $to_apply (@to_apply) {
    my ($change, @args) = @$to_apply;
    ($state, my @this_result) = $state->${\"with_${change}"}(@args);
    push @Result, @this_result;
  }
  $self->_set_shell_state($state);
  return;
}

sub is_complete_command_string {
  my ($self, $string) = @_;
  return !!$self->tcl->icall(info => complete => $string);
}

sub eval_command_string {
  my ($self, $string) = @_;
  local our @Result;
  try {
    no warnings 'redefine';
    local *DX::Utils::trace = $self->shell_state->trace_sub;
    local our $Shell_Context = $self;
    $self->tcl->Eval($string);
  } catch {
    push @Result, [ output => $_ ];
  };
  return map {
    ($_->[0] eq 'output' and ref($_->[1]))
      ? [ output => deparse($_->[1]) ]
      : $_
  } @Result;
}

sub apply_predicate {
  my ($self, $pred, @arg_strings) = @_;
  die "Can't call predicate ${pred} outside a query\n"
    unless $self->shell_state->mode eq 'query';
  my @args = $self->expand_args(@arg_strings);
  my ($intro, $need) = ({}, {});
  foreach my $arg (@args) {
    next if ref($arg);
    next if $arg =~ /^\??[a-z]/; # skip globals
    # ?Foo is intro, Foo is need
    ($arg =~ s/^\?// ? $intro : $need)->{$arg} = 1;
  }
  my $prop = DX::Proposition->new(
    predicate => $pred,
    args => \@args,
    introduced_names => $intro,
    required_names => $need,
  );
  my $old_qstate = $self->shell_state->current_query_state;
  my $qstate = $old_qstate->with_additional_proposition($prop);
  my $old_application_count = @{
    $old_qstate->search_state->current_hypothesis->action_applications
  };
  my @applications = @{
    $qstate->search_state->current_hypothesis->action_applications
  };
  push our @Result,
    map [ output => $_ ],
      @applications[$old_application_count..$#applications];
  $self->_set_shell_state(
    $self->shell_state->but(
      current_query_state => $qstate
    )
  );
  return;
}

1;