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   my $qvars;
  28   $tcl->CreateCommand('.' => sub {
  29     $self->apply_to_state([ mode => 'shell' ]);
  30     $qvars->();
  31   });
  32   $tcl->CreateCommand('...' => sub {
  33     $self->apply_to_state([ mode => 'shell' ]);
  34     my ($cur) = $self->shell_state->current_query_state;
  35     while ($cur) {
  36       $self->_set_shell_state(
  37         $self->shell_state->but(current_query_state => $cur)
  38       );
  39       $qvars->();
  40       $cur = eval { $cur->with_forced_backtrack };
  41       push our @Result, [ output => $@ ] if $@;
  42     }
  43   });
  44   $tcl->CreateCommand(qlist => sub {
  45     push our @Result, map [ output => $_ ], @{
  46       $self->shell_state->current_query_state->proposition_sequence->members
  47     };
  48     return;
  49   });
  50   $tcl->CreateCommand(qvars => $qvars = sub {
  51     my $locals = $self->shell_state->current_query_state->search_state
  52                       ->current_hypothesis->scope->locals->[0];
  53     push our @Result, [ output => $locals ];
  54     return;
  55   });
  56   $tcl->CreateCommand(qdeps => sub {
  57     my $rps = $self->shell_state->current_query_state->search_state
  58                    ->current_hypothesis->resolved_propositions;
  59     push our @Result, [ output => $rps ];
  60     return;
  61   });
  62   $tcl->CreateCommand(qact => sub {
  63     my $act = $self->shell_state->current_query_state->search_state
  64                    ->current_hypothesis->actions;
  65     push our @Result, map [ output => $_ ], @$act;
  66     return;
  67   });
  68   foreach my $pred (
  69     keys %{$self->shell_state->template_query_state->predicates}
  70   ) {
  71     $tcl->CreateCommand($pred => sub {
  72       my (undef, undef, undef, @args) = @_; # ($data, $interp, $pred)
  73       $self->apply_predicate($pred => @args);
  74     });
  75   }
  76   return $tcl;
  77 });
  78
  79 sub apply_to_state {
  80   my ($self, @to_apply) = @_;
  81   my $state = $self->shell_state;
  82   our @Result;
  83   foreach my $to_apply (@to_apply) {
  84     my ($change, @args) = @$to_apply;
  85     ($state, my @this_result) = $state->${\"with_${change}"}(@args);
  86     push @Result, @this_result;
  87   }
  88   $self->_set_shell_state($state);
  89   return;
  90 }
  91
  92 sub is_complete_command_string {
  93   my ($self, $string) = @_;
  94   return !!$self->tcl->icall(info => complete => $string);
  95 }
  96
  97 sub eval_command_string {
  98   my ($self, $string) = @_;
  99   local our @Result;
 100   try {
 101     $self->tcl->Eval($string);
 102   } catch {
 103     push @Result, [ output => $_ ];
 104   };
 105   return map {
 106     ($_->[0] eq 'output' and ref($_->[1]))
 107       ? [ output => deparse($_->[1]) ]
 108       : $_
 109   } @Result;
 110 }
 111
 112 sub apply_predicate {
 113   my ($self, $pred, @arg_strings) = @_;
 114   die "Can't call predicate ${pred} outside a query\n"
 115     unless $self->shell_state->mode eq 'query';
 116   my @args = $self->expand_args(@arg_strings);
 117   my ($intro, $need) = ({}, {});
 118   foreach my $arg (@args) {
 119     next if ref($arg);
 120     # ?Foo is intro, Foo is need
 121     ($arg =~ s/^\?// ? $intro : $need)->{$arg} = 1;
 122   }
 123   my $prop = DX::Proposition->new(
 124     predicate => $pred,
 125     args => \@args,
 126     introduced_names => $intro,
 127     required_names => $need,
 128   );
 129   my $old_qstate = $self->shell_state->current_query_state;
 130   my $qstate = $old_qstate->with_additional_proposition($prop);
 131   my $old_application_count = @{
 132     $old_qstate->search_state->current_hypothesis->action_applications
 133   };
 134   my @applications = @{
 135     $qstate->search_state->current_hypothesis->action_applications
 136   };
 137   push our @Result,
 138     map [ output => $_ ],
 139       @applications[$old_application_count..$#applications];
 140   $self->_set_shell_state(
 141     $self->shell_state->but(
 142       current_query_state => $qstate
 143     )
 144   );
 145   return;
 146 }
 147
 148 1;