1 package DX::ShellSession;
4 use Scalar::Util qw(weaken);
7 use DX::ActionBuilder::Normal;
8 use DX::RuleDefinitionContext;
9 use DX::Utils qw(deparse);
12 has shell_state => (is => 'rwp', required => 1, isa => ShellState);
15 is => 'lazy', builder => sub { DX::Expander->new(tcl => $_[0]->tcl) },
16 handles => [ qw(expand_args) ],
19 has tcl => (is => 'lazy', builder => sub {
23 $tcl->CreateCommand('?' => sub {
24 $self->apply_to_state([ 'new_query_state' ], [ mode => 'query' ]);
26 $tcl->CreateCommand('?+' => sub {
27 $self->apply_to_state([ mode => 'query' ]);
30 $tcl->CreateCommand('.' => sub {
31 $self->apply_to_state([ mode => 'shell' ]);
34 $tcl->CreateCommand('...' => sub {
35 $self->apply_to_state([ mode => 'shell' ]);
36 my $orig = my $cur = $self->shell_state->current_query_state;
38 $self->_set_shell_state(
39 $self->shell_state->but(current_query_state => $cur)
42 $cur = eval { $cur->with_forced_backtrack };
43 push our @Result, [ output => $@ ] if $@;
45 $self->_set_shell_state(
46 $self->shell_state->but(
47 current_query_state => $orig
52 $tcl->CreateCommand(qlist => sub {
53 push our @Result, map [ output => $_ ], @{
54 $self->shell_state->current_query_state->proposition_sequence->members
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 ];
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 ];
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;
77 keys %{$self->shell_state->template_query_state->predicates}
79 $tcl->CreateCommand($pred => sub {
80 my (undef, undef, undef, @args) = @_; # ($data, $interp, $pred)
81 (our $Shell_Context)->apply_predicate($pred => @args);
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 => $self->expand_args($value),
92 $self->_set_shell_state(
93 $self->shell_state->but(
94 template_query_state => $new_tqs
98 $tcl->CreateCommand(state => sub {
99 my (undef, undef, undef, $name, $value) = @_;
100 my $tqs = $self->shell_state->template_query_state;
101 my $new_tqs = $tqs->but(
102 globals => $tqs->globals->with_member_at(
103 $name => DX::ActionBuilder::Normal->new(
104 target_path => [ $name ],
105 )->apply_to_value($self->expand_args($value)),
108 $self->_set_shell_state(
109 $self->shell_state->but(
110 template_query_state => $new_tqs
114 $tcl->CreateCommand(trace => sub {
115 my (undef, undef, undef, @trace) = @_;
116 $self->_set_shell_state(
117 $self->shell_state->with_trace_changes(@trace)
120 $tcl->CreateCommand(rule => sub {
121 my (undef, undef, undef, $pred, $args, $body) = @_;
122 local our $Shell_Context = DX::RuleDefinitionContext->new(
123 arg_names => [ $self->tcl->SplitList($args) ],
124 expander => $self->expander,
126 $self->tcl->Eval($body);
127 my $rule = $Shell_Context->bake_rule;
128 my $tqs = $self->shell_state->template_query_state;
129 my $new_tqs = $tqs->but(
135 $self->_set_shell_state(
136 $self->shell_state->but(
137 template_query_state => $new_tqs
140 $self->tcl->CreateCommand($pred => sub {
141 my (undef, undef, undef, @args) = @_; # ($data, $interp, $pred)
142 (our $Shell_Context)->apply_predicate($pred => @args);
149 my ($self, @to_apply) = @_;
150 my $state = $self->shell_state;
152 foreach my $to_apply (@to_apply) {
153 my ($change, @args) = @$to_apply;
154 ($state, my @this_result) = $state->${\"with_${change}"}(@args);
155 push @Result, @this_result;
157 $self->_set_shell_state($state);
161 sub is_complete_command_string {
162 my ($self, $string) = @_;
163 return !!$self->tcl->icall(info => complete => $string);
166 sub eval_command_string {
167 my ($self, $string) = @_;
170 no warnings 'redefine';
171 local *DX::Utils::trace = $self->shell_state->trace_sub;
172 local our $Shell_Context = $self;
173 $self->tcl->Eval($string);
175 push @Result, [ output => $_ ];
178 ($_->[0] eq 'output' and ref($_->[1]))
179 ? [ output => deparse($_->[1]) ]
184 sub apply_predicate {
185 my ($self, $pred, @arg_strings) = @_;
186 die "Can't call predicate ${pred} outside a query\n"
187 unless $self->shell_state->mode eq 'query';
188 my @args = $self->expand_args(@arg_strings);
189 my ($intro, $need) = ({}, {});
190 foreach my $arg (@args) {
192 next if $arg =~ /^\??[a-z]/; # skip globals
193 # ?Foo is intro, Foo is need
194 ($arg =~ s/^\?// ? $intro : $need)->{$arg} = 1;
196 my $prop = DX::Proposition->new(
199 introduced_names => $intro,
200 required_names => $need,
202 my $old_qstate = $self->shell_state->current_query_state;
203 my $qstate = $old_qstate->with_additional_proposition($prop);
204 my $old_application_count = @{
205 $old_qstate->search_state->current_hypothesis->action_applications
207 my @applications = @{
208 $qstate->search_state->current_hypothesis->action_applications
211 map [ output => $_ ],
212 @applications[$old_application_count..$#applications];
213 $self->_set_shell_state(
214 $self->shell_state->but(
215 current_query_state => $qstate