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' ]); |
34 | my ($cur) = $self->shell_state->current_query_state; |
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 | } |
43 | }); |
d1b6cb33 |
44 | $tcl->CreateCommand(qlist => sub { |
45 | push our @Result, map [ output => $_ ], @{ |
46 | $self->shell_state->current_query_state->proposition_sequence->members |
47 | }; |
48 | return; |
49 | }); |
384a5e93 |
50 | $tcl->CreateCommand(qvars => $qvars = sub { |
51 | my $locals = $self->shell_state->current_query_state->search_state |
52 | ->current_hypothesis->scope->locals->[0]; |
53 | push our @Result, [ output => $locals ]; |
54 | return; |
55 | }); |
aae0d764 |
56 | $tcl->CreateCommand(qdeps => sub { |
57 | my $rps = $self->shell_state->current_query_state->search_state |
58 | ->current_hypothesis->resolved_propositions; |
59 | push our @Result, [ output => $rps ]; |
60 | return; |
61 | }); |
1e90aa03 |
62 | $tcl->CreateCommand(qact => sub { |
63 | my $act = $self->shell_state->current_query_state->search_state |
64 | ->current_hypothesis->actions; |
65 | push our @Result, map [ output => $_ ], @$act; |
66 | return; |
67 | }); |
fa8f5696 |
68 | foreach my $pred ( |
69 | keys %{$self->shell_state->template_query_state->predicates} |
70 | ) { |
71 | $tcl->CreateCommand($pred => sub { |
72 | my (undef, undef, undef, @args) = @_; # ($data, $interp, $pred) |
73 | $self->apply_predicate($pred => @args); |
74 | }); |
75 | } |
9eedd677 |
76 | return $tcl; |
77 | }); |
78 | |
79 | sub apply_to_state { |
80 | my ($self, @to_apply) = @_; |
81 | my $state = $self->shell_state; |
82 | our @Result; |
83 | foreach my $to_apply (@to_apply) { |
84 | my ($change, @args) = @$to_apply; |
85 | ($state, my @this_result) = $state->${\"with_${change}"}(@args); |
86 | push @Result, @this_result; |
87 | } |
88 | $self->_set_shell_state($state); |
89 | return; |
90 | } |
91 | |
92 | sub is_complete_command_string { |
93 | my ($self, $string) = @_; |
94 | return !!$self->tcl->icall(info => complete => $string); |
95 | } |
96 | |
97 | sub eval_command_string { |
98 | my ($self, $string) = @_; |
99 | local our @Result; |
fa8f5696 |
100 | try { |
101 | $self->tcl->Eval($string); |
102 | } catch { |
103 | push @Result, [ output => $_ ]; |
104 | }; |
d1b6cb33 |
105 | return map { |
106 | ($_->[0] eq 'output' and ref($_->[1])) |
107 | ? [ output => deparse($_->[1]) ] |
108 | : $_ |
109 | } @Result; |
9eedd677 |
110 | } |
111 | |
fa8f5696 |
112 | sub apply_predicate { |
d1b6cb33 |
113 | my ($self, $pred, @arg_strings) = @_; |
fa8f5696 |
114 | die "Can't call predicate ${pred} outside a query\n" |
115 | unless $self->shell_state->mode eq 'query'; |
d1b6cb33 |
116 | my @args = $self->expand_args(@arg_strings); |
384a5e93 |
117 | my ($intro, $need) = ({}, {}); |
d1b6cb33 |
118 | foreach my $arg (@args) { |
119 | next if ref($arg); |
120 | # ?Foo is intro, Foo is need |
121 | ($arg =~ s/^\?// ? $intro : $need)->{$arg} = 1; |
122 | } |
123 | my $prop = DX::Proposition->new( |
124 | predicate => $pred, |
125 | args => \@args, |
5f12a9d8 |
126 | introduced_names => $intro, |
127 | required_names => $need, |
d1b6cb33 |
128 | ); |
31d445d3 |
129 | my $old_qstate = $self->shell_state->current_query_state; |
130 | my $qstate = $old_qstate->with_additional_proposition($prop); |
e442aff8 |
131 | my $old_application_count = @{ |
132 | $old_qstate->search_state->current_hypothesis->action_applications |
133 | }; |
134 | my @applications = @{ |
135 | $qstate->search_state->current_hypothesis->action_applications |
31d445d3 |
136 | }; |
31d445d3 |
137 | push our @Result, |
e442aff8 |
138 | map [ output => $_ ], |
139 | @applications[$old_application_count..$#applications]; |
d1b6cb33 |
140 | $self->_set_shell_state( |
141 | $self->shell_state->but( |
142 | current_query_state => $qstate |
143 | ) |
144 | ); |
145 | return; |
fa8f5696 |
146 | } |
147 | |
9eedd677 |
148 | 1; |