use Scalar::Util qw(weaken);
use DX::Expander;
use DX::Proposition;
+use DX::ActionBuilder::Normal;
+use DX::RuleDefinitionContext;
use DX::Utils qw(deparse);
use DX::Class;
});
$tcl->CreateCommand('...' => sub {
$self->apply_to_state([ mode => 'shell' ]);
- my ($cur) = $self->shell_state->current_query_state;
+ my $orig = my $cur = $self->shell_state->current_query_state;
while ($cur) {
$self->_set_shell_state(
$self->shell_state->but(current_query_state => $cur)
$cur = eval { $cur->with_forced_backtrack };
push our @Result, [ output => $@ ] if $@;
}
+ $self->_set_shell_state(
+ $self->shell_state->but(
+ current_query_state => $orig
+ ),
+ );
+ return;
});
$tcl->CreateCommand(qlist => sub {
push our @Result, map [ output => $_ ], @{
) {
$tcl->CreateCommand($pred => sub {
my (undef, undef, undef, @args) = @_; # ($data, $interp, $pred)
- $self->apply_predicate($pred => @args);
+ (our $Shell_Context)->apply_predicate($pred => @args);
});
}
+ $tcl->CreateCommand(const => sub {
+ my (undef, undef, undef, $name, $value) = @_;
+ my $tqs = $self->shell_state->template_query_state;
+ my $new_tqs = $tqs->but(
+ globals => $tqs->globals->with_member_at(
+ $name => DX::ActionBuilder::Null->new(
+ target_path => [ $name ],
+ )->apply_to_value($self->expand_args($value)),
+ ),
+ );
+ $self->_set_shell_state(
+ $self->shell_state->but(
+ template_query_state => $new_tqs
+ ),
+ );
+ });
+ $tcl->CreateCommand(state => sub {
+ my (undef, undef, undef, $name, $value) = @_;
+ my $tqs = $self->shell_state->template_query_state;
+ my $new_tqs = $tqs->but(
+ globals => $tqs->globals->with_member_at(
+ $name => DX::ActionBuilder::Normal->new(
+ target_path => [ $name ],
+ )->apply_to_value($self->expand_args($value)),
+ ),
+ );
+ $self->_set_shell_state(
+ $self->shell_state->but(
+ template_query_state => $new_tqs
+ ),
+ );
+ });
+ $tcl->CreateCommand(trace => sub {
+ my (undef, undef, undef, @trace) = @_;
+ $self->_set_shell_state(
+ $self->shell_state->with_trace_changes(@trace)
+ );
+ });
+ $tcl->CreateCommand(rule => sub {
+ my (undef, undef, undef, $pred, $args, $body) = @_;
+ local our $Shell_Context = DX::RuleDefinitionContext->new(
+ arg_names => [ $self->tcl->SplitList($args) ],
+ expander => $self->expander,
+ );
+ $self->tcl->Eval($body);
+ my $rule = $Shell_Context->bake_rule;
+ my $tqs = $self->shell_state->template_query_state;
+ my $new_tqs = $tqs->but(
+ predicates => {
+ %{$tqs->predicates},
+ $pred => $rule,
+ },
+ );
+ $self->_set_shell_state(
+ $self->shell_state->but(
+ template_query_state => $new_tqs
+ ),
+ );
+ $self->tcl->CreateCommand($pred => sub {
+ my (undef, undef, undef, @args) = @_; # ($data, $interp, $pred)
+ (our $Shell_Context)->apply_predicate($pred => @args);
+ });
+ });
return $tcl;
});
my ($self, $string) = @_;
local our @Result;
try {
+ no warnings 'redefine';
+ local *DX::Utils::trace = $self->shell_state->trace_sub;
+ local our $Shell_Context = $self;
$self->tcl->Eval($string);
} catch {
push @Result, [ output => $_ ];
my ($intro, $need) = ({}, {});
foreach my $arg (@args) {
next if ref($arg);
+ next if $arg =~ /^\??[a-z]/; # skip globals
# ?Foo is intro, Foo is need
($arg =~ s/^\?// ? $intro : $need)->{$arg} = 1;
}