lib/DX/ShellSession.pm

   1 package DX::ShellSession;
   2
   3 use Tcl;
   4 use Scalar::Util qw(weaken);
   5 use DX::Expander;
   6 use DX::Proposition;
   7 use DX::Utils qw(deparse);
   8 use DX::Class;
   9
  10 has shell_state => (is => 'rwp', required => 1, isa => ShellState);
  11
  12 has expander => (
  13   is => 'lazy', builder => sub { DX::Expander->new(tcl => $_[0]->tcl) },
  14   handles => [ qw(expand_args) ],
  15 );
  16
  17 has tcl => (is => 'lazy', builder => sub {
  18   my ($self) = @_;
  19   weaken $self;
  20   my $tcl = Tcl->new;
  21   $tcl->CreateCommand('?' => sub {
  22     $self->apply_to_state([ 'new_query_state' ], [ mode => 'query' ])
  23   });
  24   $tcl->CreateCommand('?+' => sub {
  25     $self->apply_to_state([ mode => 'query' ])
  26   });
  27   $tcl->CreateCommand('.' => sub {
  28     $self->apply_to_state([ mode => 'shell' ])
  29   });
  30   $tcl->CreateCommand(qlist => sub {
  31     push our @Result, map [ output => $_ ], @{
  32       $self->shell_state->current_query_state->proposition_sequence->members
  33     };
  34     return;
  35   });
  36   foreach my $pred (
  37     keys %{$self->shell_state->template_query_state->predicates}
  38   ) {
  39     $tcl->CreateCommand($pred => sub {
  40       my (undef, undef, undef, @args) = @_; # ($data, $interp, $pred)
  41       $self->apply_predicate($pred => @args);
  42     });
  43   }
  44   return $tcl;
  45 });
  46
  47 sub apply_to_state {
  48   my ($self, @to_apply) = @_;
  49   my $state = $self->shell_state;
  50   our @Result;
  51   foreach my $to_apply (@to_apply) {
  52     my ($change, @args) = @$to_apply;
  53     ($state, my @this_result) = $state->${\"with_${change}"}(@args);
  54     push @Result, @this_result;
  55   }
  56   $self->_set_shell_state($state);
  57   return;
  58 }
  59
  60 sub is_complete_command_string {
  61   my ($self, $string) = @_;
  62   return !!$self->tcl->icall(info => complete => $string);
  63 }
  64
  65 sub eval_command_string {
  66   my ($self, $string) = @_;
  67   local our @Result;
  68   try {
  69     $self->tcl->Eval($string);
  70   } catch {
  71     push @Result, [ output => $_ ];
  72   };
  73   return map {
  74     ($_->[0] eq 'output' and ref($_->[1]))
  75       ? [ output => deparse($_->[1]) ]
  76       : $_
  77   } @Result;
  78 }
  79
  80 sub apply_predicate {
  81   my ($self, $pred, @arg_strings) = @_;
  82   die "Can't call predicate ${pred} outside a query\n"
  83     unless $self->shell_state->mode eq 'query';
  84   my @args = $self->expand_args(@arg_strings);
  85   my $intro; my $need;
  86   foreach my $arg (@args) {
  87     next if ref($arg);
  88     # ?Foo is intro, Foo is need
  89     ($arg =~ s/^\?// ? $intro : $need)->{$arg} = 1;
  90   }
  91   my $prop = DX::Proposition->new(
  92     predicate => $pred,
  93     args => \@args,
  94     introduces_names => $intro,
  95     requires_names => $need,
  96   );
  97   my $qstate = $self->shell_state->current_query_state;
  98   $qstate = $qstate->but(
  99     proposition_sequence => $qstate->proposition_sequence
 100                                    ->but_append_proposition($prop)
 101   );
 102   $self->_set_shell_state(
 103     $self->shell_state->but(
 104       current_query_state => $qstate
 105     )
 106   );
 107   return;
 108 }
 109
 110 1;