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