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