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