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