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