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 $orig = 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     $self->_set_shell_state(
  44       $self->shell_state->but(
  45         current_query_state => $orig
  46       ),
  47     );
  48     return;
  49   });
  50   $tcl->CreateCommand(qlist => sub {
  51     push our @Result, map [ output => $_ ], @{
  52       $self->shell_state->current_query_state->proposition_sequence->members
  53     };
  54     return;
  55   });
  56   $tcl->CreateCommand(qvars => $qvars = sub {
  57     my $locals = $self->shell_state->current_query_state->search_state
  58                       ->current_hypothesis->scope->locals->[0];
  59     push our @Result, [ output => $locals ];
  60     return;
  61   });
  62   $tcl->CreateCommand(qdeps => sub {
  63     my $rps = $self->shell_state->current_query_state->search_state
  64                    ->current_hypothesis->resolved_propositions;
  65     push our @Result, [ output => $rps ];
  66     return;
  67   });
  68   $tcl->CreateCommand(qact => sub {
  69     my $act = $self->shell_state->current_query_state->search_state
  70                    ->current_hypothesis->actions;
  71     push our @Result, map [ output => $_ ], @$act;
  72     return;
  73   });
  74   foreach my $pred (
  75     keys %{$self->shell_state->template_query_state->predicates}
  76   ) {
  77     $tcl->CreateCommand($pred => sub {
  78       my (undef, undef, undef, @args) = @_; # ($data, $interp, $pred)
  79       $self->apply_predicate($pred => @args);
  80     });
  81   }
  82   $tcl->CreateCommand(const => sub {
  83     my (undef, undef, undef, $name, $value) = @_;
  84     my $tqs = $self->shell_state->template_query_state;
  85     my $new_tqs = $tqs->but(
  86       globals => $tqs->globals->with_member_at(
  87         $name => $self->expand_args($value),
  88       ),
  89     );
  90     $self->_set_shell_state(
  91       $self->shell_state->but(
  92         template_query_state => $new_tqs
  93       ),
  94     );
  95   });
  96   $tcl->CreateCommand(trace => sub {
  97     my (undef, undef, undef, @trace) = @_;
  98     $self->_set_shell_state(
  99       $self->shell_state->with_trace_changes(@trace)
 100     );
 101   });
 102   return $tcl;
 103 });
 104
 105 sub apply_to_state {
 106   my ($self, @to_apply) = @_;
 107   my $state = $self->shell_state;
 108   our @Result;
 109   foreach my $to_apply (@to_apply) {
 110     my ($change, @args) = @$to_apply;
 111     ($state, my @this_result) = $state->${\"with_${change}"}(@args);
 112     push @Result, @this_result;
 113   }
 114   $self->_set_shell_state($state);
 115   return;
 116 }
 117
 118 sub is_complete_command_string {
 119   my ($self, $string) = @_;
 120   return !!$self->tcl->icall(info => complete => $string);
 121 }
 122
 123 sub eval_command_string {
 124   my ($self, $string) = @_;
 125   local our @Result;
 126   try {
 127     no warnings 'redefine';
 128     local *DX::Utils::trace = $self->shell_state->trace_sub;
 129     $self->tcl->Eval($string);
 130   } catch {
 131     push @Result, [ output => $_ ];
 132   };
 133   return map {
 134     ($_->[0] eq 'output' and ref($_->[1]))
 135       ? [ output => deparse($_->[1]) ]
 136       : $_
 137   } @Result;
 138 }
 139
 140 sub apply_predicate {
 141   my ($self, $pred, @arg_strings) = @_;
 142   die "Can't call predicate ${pred} outside a query\n"
 143     unless $self->shell_state->mode eq 'query';
 144   my @args = $self->expand_args(@arg_strings);
 145   my ($intro, $need) = ({}, {});
 146   foreach my $arg (@args) {
 147     next if ref($arg);
 148     next if $arg =~ /^\??[a-z]/; # skip globals
 149     # ?Foo is intro, Foo is need
 150     ($arg =~ s/^\?// ? $intro : $need)->{$arg} = 1;
 151   }
 152   my $prop = DX::Proposition->new(
 153     predicate => $pred,
 154     args => \@args,
 155     introduced_names => $intro,
 156     required_names => $need,
 157   );
 158   my $old_qstate = $self->shell_state->current_query_state;
 159   my $qstate = $old_qstate->with_additional_proposition($prop);
 160   my $old_application_count = @{
 161     $old_qstate->search_state->current_hypothesis->action_applications
 162   };
 163   my @applications = @{
 164     $qstate->search_state->current_hypothesis->action_applications
 165   };
 166   push our @Result,
 167     map [ output => $_ ],
 168       @applications[$old_application_count..$#applications];
 169   $self->_set_shell_state(
 170     $self->shell_state->but(
 171       current_query_state => $qstate
 172     )
 173   );
 174   return;
 175 }
 176
 177 1;