format aperture in backtrack trace
[scpubgit/DX.git] / lib / DX / ShellSession.pm
CommitLineData
9eedd677 1package DX::ShellSession;
2
3use Tcl;
4use Scalar::Util qw(weaken);
fa8f5696 5use DX::Expander;
d1b6cb33 6use DX::Proposition;
bc0773eb 7use DX::ActionBuilder::Normal;
2bf57c95 8use DX::RuleDefinitionContext;
d1b6cb33 9use DX::Utils qw(deparse);
2548ce61 10use Types::Standard qw(InstanceOf);
9eedd677 11use DX::Class;
12
13has shell_state => (is => 'rwp', required => 1, isa => ShellState);
14
fa8f5696 15has expander => (
16 is => 'lazy', builder => sub { DX::Expander->new(tcl => $_[0]->tcl) },
cfae7810 17 isa => Expander, handles => [ qw(expand_args) ],
fa8f5696 18);
19
2548ce61 20has 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
151sub 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
164sub is_complete_command_string {
165 my ($self, $string) = @_;
166 return !!$self->tcl->icall(info => complete => $string);
167}
168
169sub 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 187sub 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 2241;