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::ActionBuilder::Normal;
   8 use DX::Utils qw(deparse);
   9 use DX::Class;
  10
  11 has shell_state => (is => 'rwp', required => 1, isa => ShellState);
  12
  13 has expander => (
  14   is => 'lazy', builder => sub { DX::Expander->new(tcl => $_[0]->tcl) },
  15   handles => [ qw(expand_args) ],
  16 );
  17
  18 has tcl => (is => 'lazy', builder => sub {
  19   my ($self) = @_;
  20   weaken $self;
  21   my $tcl = Tcl->new;
  22   $tcl->CreateCommand('?' => sub {
  23     $self->apply_to_state([ 'new_query_state' ], [ mode => 'query' ]);
  24   });
  25   $tcl->CreateCommand('?+' => sub {
  26     $self->apply_to_state([ mode => 'query' ]);
  27   });
  28   my $qvars;
  29   $tcl->CreateCommand('.' => sub {
  30     $self->apply_to_state([ mode => 'shell' ]);
  31     $qvars->();
  32   });
  33   $tcl->CreateCommand('...' => sub {
  34     $self->apply_to_state([ mode => 'shell' ]);
  35     my $orig = my $cur = $self->shell_state->current_query_state;
  36     while ($cur) {
  37       $self->_set_shell_state(
  38         $self->shell_state->but(current_query_state => $cur)
  39       );
  40       $qvars->();
  41       $cur = eval { $cur->with_forced_backtrack };
  42       push our @Result, [ output => $@ ] if $@;
  43     }
  44     $self->_set_shell_state(
  45       $self->shell_state->but(
  46         current_query_state => $orig
  47       ),
  48     );
  49     return;
  50   });
  51   $tcl->CreateCommand(qlist => sub {
  52     push our @Result, map [ output => $_ ], @{
  53       $self->shell_state->current_query_state->proposition_sequence->members
  54     };
  55     return;
  56   });
  57   $tcl->CreateCommand(qvars => $qvars = sub {
  58     my $locals = $self->shell_state->current_query_state->search_state
  59                       ->current_hypothesis->scope->locals->[0];
  60     push our @Result, [ output => $locals ];
  61     return;
  62   });
  63   $tcl->CreateCommand(qdeps => sub {
  64     my $rps = $self->shell_state->current_query_state->search_state
  65                    ->current_hypothesis->resolved_propositions;
  66     push our @Result, [ output => $rps ];
  67     return;
  68   });
  69   $tcl->CreateCommand(qact => sub {
  70     my $act = $self->shell_state->current_query_state->search_state
  71                    ->current_hypothesis->actions;
  72     push our @Result, map [ output => $_ ], @$act;
  73     return;
  74   });
  75   foreach my $pred (
  76     keys %{$self->shell_state->template_query_state->predicates}
  77   ) {
  78     $tcl->CreateCommand($pred => sub {
  79       my (undef, undef, undef, @args) = @_; # ($data, $interp, $pred)
  80       $self->apply_predicate($pred => @args);
  81     });
  82   }
  83   $tcl->CreateCommand(const => sub {
  84     my (undef, undef, undef, $name, $value) = @_;
  85     my $tqs = $self->shell_state->template_query_state;
  86     my $new_tqs = $tqs->but(
  87       globals => $tqs->globals->with_member_at(
  88         $name => $self->expand_args($value),
  89       ),
  90     );
  91     $self->_set_shell_state(
  92       $self->shell_state->but(
  93         template_query_state => $new_tqs
  94       ),
  95     );
  96   });
  97   $tcl->CreateCommand(state => sub {
  98     my (undef, undef, undef, $name, $value) = @_;
  99     my $tqs = $self->shell_state->template_query_state;
 100     my $new_tqs = $tqs->but(
 101       globals => $tqs->globals->with_member_at(
 102         $name => DX::ActionBuilder::Normal->new(
 103                    target_path => [ $name ],
 104                  )->apply_to_value($self->expand_args($value)),
 105       ),
 106     );
 107     $self->_set_shell_state(
 108       $self->shell_state->but(
 109         template_query_state => $new_tqs
 110       ),
 111     );
 112   });
 113   $tcl->CreateCommand(trace => sub {
 114     my (undef, undef, undef, @trace) = @_;
 115     $self->_set_shell_state(
 116       $self->shell_state->with_trace_changes(@trace)
 117     );
 118   });
 119   return $tcl;
 120 });
 121
 122 sub apply_to_state {
 123   my ($self, @to_apply) = @_;
 124   my $state = $self->shell_state;
 125   our @Result;
 126   foreach my $to_apply (@to_apply) {
 127     my ($change, @args) = @$to_apply;
 128     ($state, my @this_result) = $state->${\"with_${change}"}(@args);
 129     push @Result, @this_result;
 130   }
 131   $self->_set_shell_state($state);
 132   return;
 133 }
 134
 135 sub is_complete_command_string {
 136   my ($self, $string) = @_;
 137   return !!$self->tcl->icall(info => complete => $string);
 138 }
 139
 140 sub eval_command_string {
 141   my ($self, $string) = @_;
 142   local our @Result;
 143   try {
 144     no warnings 'redefine';
 145     local *DX::Utils::trace = $self->shell_state->trace_sub;
 146     $self->tcl->Eval($string);
 147   } catch {
 148     push @Result, [ output => $_ ];
 149   };
 150   return map {
 151     ($_->[0] eq 'output' and ref($_->[1]))
 152       ? [ output => deparse($_->[1]) ]
 153       : $_
 154   } @Result;
 155 }
 156
 157 sub apply_predicate {
 158   my ($self, $pred, @arg_strings) = @_;
 159   die "Can't call predicate ${pred} outside a query\n"
 160     unless $self->shell_state->mode eq 'query';
 161   my @args = $self->expand_args(@arg_strings);
 162   my ($intro, $need) = ({}, {});
 163   foreach my $arg (@args) {
 164     next if ref($arg);
 165     next if $arg =~ /^\??[a-z]/; # skip globals
 166     # ?Foo is intro, Foo is need
 167     ($arg =~ s/^\?// ? $intro : $need)->{$arg} = 1;
 168   }
 169   my $prop = DX::Proposition->new(
 170     predicate => $pred,
 171     args => \@args,
 172     introduced_names => $intro,
 173     required_names => $need,
 174   );
 175   my $old_qstate = $self->shell_state->current_query_state;
 176   my $qstate = $old_qstate->with_additional_proposition($prop);
 177   my $old_application_count = @{
 178     $old_qstate->search_state->current_hypothesis->action_applications
 179   };
 180   my @applications = @{
 181     $qstate->search_state->current_hypothesis->action_applications
 182   };
 183   push our @Result,
 184     map [ output => $_ ],
 185       @applications[$old_application_count..$#applications];
 186   $self->_set_shell_state(
 187     $self->shell_state->but(
 188       current_query_state => $qstate
 189     )
 190   );
 191   return;
 192 }
 193
 194 1;