Commit | Line | Data |
9eedd677 |
1 | package DX::ShellSession; |
2 | |
3 | use Tcl; |
4 | use Scalar::Util qw(weaken); |
fa8f5696 |
5 | use DX::Expander; |
d1b6cb33 |
6 | use DX::Proposition; |
bc0773eb |
7 | use DX::ActionBuilder::Normal; |
2bf57c95 |
8 | use DX::RuleDefinitionContext; |
d1b6cb33 |
9 | use DX::Utils qw(deparse); |
9eedd677 |
10 | use DX::Class; |
11 | |
12 | has shell_state => (is => 'rwp', required => 1, isa => ShellState); |
13 | |
fa8f5696 |
14 | has expander => ( |
15 | is => 'lazy', builder => sub { DX::Expander->new(tcl => $_[0]->tcl) }, |
16 | handles => [ qw(expand_args) ], |
17 | ); |
18 | |
9eedd677 |
19 | has tcl => (is => 'lazy', builder => sub { |
20 | my ($self) = @_; |
21 | weaken $self; |
22 | my $tcl = Tcl->new; |
23 | $tcl->CreateCommand('?' => sub { |
384a5e93 |
24 | $self->apply_to_state([ 'new_query_state' ], [ mode => 'query' ]); |
9eedd677 |
25 | }); |
26 | $tcl->CreateCommand('?+' => sub { |
384a5e93 |
27 | $self->apply_to_state([ mode => 'query' ]); |
9eedd677 |
28 | }); |
384a5e93 |
29 | my $qvars; |
9eedd677 |
30 | $tcl->CreateCommand('.' => sub { |
384a5e93 |
31 | $self->apply_to_state([ mode => 'shell' ]); |
32 | $qvars->(); |
9eedd677 |
33 | }); |
f458fa2c |
34 | $tcl->CreateCommand('...' => sub { |
35 | $self->apply_to_state([ mode => 'shell' ]); |
d294025e |
36 | my $orig = my $cur = $self->shell_state->current_query_state; |
f458fa2c |
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 | } |
d294025e |
45 | $self->_set_shell_state( |
46 | $self->shell_state->but( |
47 | current_query_state => $orig |
48 | ), |
49 | ); |
50 | return; |
f458fa2c |
51 | }); |
d1b6cb33 |
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 | }); |
384a5e93 |
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 | }); |
aae0d764 |
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 | }); |
1e90aa03 |
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 | }); |
fa8f5696 |
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) |
2bf57c95 |
81 | (our $Shell_Context)->apply_predicate($pred => @args); |
fa8f5696 |
82 | }); |
83 | } |
bcee3a69 |
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( |
345270ac |
89 | $name => DX::ActionBuilder::Null->new( |
90 | target_path => [ $name ], |
91 | )->apply_to_value($self->expand_args($value)), |
bcee3a69 |
92 | ), |
93 | ); |
94 | $self->_set_shell_state( |
95 | $self->shell_state->but( |
96 | template_query_state => $new_tqs |
97 | ), |
98 | ); |
99 | }); |
bc0773eb |
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 | }); |
d294025e |
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 | }); |
2bf57c95 |
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 | }); |
9eedd677 |
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; |
fa8f5696 |
171 | try { |
bcee3a69 |
172 | no warnings 'redefine'; |
173 | local *DX::Utils::trace = $self->shell_state->trace_sub; |
2bf57c95 |
174 | local our $Shell_Context = $self; |
fa8f5696 |
175 | $self->tcl->Eval($string); |
176 | } catch { |
177 | push @Result, [ output => $_ ]; |
178 | }; |
d1b6cb33 |
179 | return map { |
180 | ($_->[0] eq 'output' and ref($_->[1])) |
181 | ? [ output => deparse($_->[1]) ] |
182 | : $_ |
183 | } @Result; |
9eedd677 |
184 | } |
185 | |
fa8f5696 |
186 | sub apply_predicate { |
d1b6cb33 |
187 | my ($self, $pred, @arg_strings) = @_; |
fa8f5696 |
188 | die "Can't call predicate ${pred} outside a query\n" |
189 | unless $self->shell_state->mode eq 'query'; |
d1b6cb33 |
190 | my @args = $self->expand_args(@arg_strings); |
384a5e93 |
191 | my ($intro, $need) = ({}, {}); |
d1b6cb33 |
192 | foreach my $arg (@args) { |
193 | next if ref($arg); |
bcee3a69 |
194 | next if $arg =~ /^\??[a-z]/; # skip globals |
d1b6cb33 |
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, |
5f12a9d8 |
201 | introduced_names => $intro, |
202 | required_names => $need, |
d1b6cb33 |
203 | ); |
31d445d3 |
204 | my $old_qstate = $self->shell_state->current_query_state; |
205 | my $qstate = $old_qstate->with_additional_proposition($prop); |
e442aff8 |
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 |
31d445d3 |
211 | }; |
31d445d3 |
212 | push our @Result, |
e442aff8 |
213 | map [ output => $_ ], |
214 | @applications[$old_application_count..$#applications]; |
d1b6cb33 |
215 | $self->_set_shell_state( |
216 | $self->shell_state->but( |
217 | current_query_state => $qstate |
218 | ) |
219 | ); |
220 | return; |
fa8f5696 |
221 | } |
222 | |
9eedd677 |
223 | 1; |