lib/DX/State.pm

   1 package DX::State;
   2
   3 use Return::MultiLevel qw(with_return);
   4 use DX::Op::FromCode;
   5 use Scalar::Util qw(blessed);
   6 use Moo;
   7
   8 has next_op => (is => 'ro', required => 1);
   9
  10 has return_stack => (is => 'ro', required => 1);
  11
  12 has by_id => (is => 'ro', required => 1);
  13
  14 has scope => (is => 'ro', required => 1);
  15
  16 has last_choice => (is => 'ro', required => 1);
  17
  18 has id_gen => (is => 'ro', default => sub { {} });
  19
  20 has rule_set => (is => 'ro');
  21
  22 has facts => (is => 'ro');
  23
  24 sub scope_var {
  25   my ($self, $name) = @_;
  26   $self->by_id->{$self->scope->{$name}};
  27 }
  28
  29 sub allocate_var {
  30   my ($self, $name, $var) = @_;
  31   my $id = join('_', $name, ++($self->id_gen->{$name}));
  32   DX::Var->new(id => $id, %$var);
  33 }
  34
  35 sub assign_vars {
  36   my ($self, %vars) = @_;
  37   my %by_id = %{$self->by_id};
  38   my $state = $self->but(id_gen => { %{$self->id_gen} });
  39   foreach my $name (keys %vars) {
  40     unless (blessed($vars{$name})) {
  41       my $var = $vars{$name} = $state->allocate_var($name, $vars{$name});
  42       $by_id{$var->id} = $var;
  43     }
  44   }
  45   $state->but(
  46     by_id => \%by_id,
  47     scope => { %{$self->scope}, map +($_ => $vars{$_}->id), keys %vars }
  48   );
  49 }
  50
  51 sub bind_var_then {
  52   my ($self, $var, $value, $then) = @_;
  53   my $bound = $var->with_value($value);
  54   $self->but(
  55     by_id => { %{$self->by_id}, $var->id => $bound },
  56     next_op => $then
  57   );
  58 }
  59
  60 sub bind_stream_then {
  61   my ($self, $var, $stream, $then) = @_;
  62   my $bound = $var->with_stream($stream);
  63   $self->but(
  64     by_id => { %{$self->by_id}, $var->id => $bound },
  65     next_op => $then
  66   )->mark_choice($bound);
  67 }
  68
  69 sub mark_choice {
  70   my ($self, $var) = @_;
  71   $self->but(last_choice => [ $self, $var ]);
  72 }
  73
  74 sub backtrack {
  75   my ($self) = @_;
  76   my ($state, $var) = ($self);
  77   while (($state, $var) = @{$state->last_choice}) {
  78     $var->bound_value; $var->clear_bound_value;
  79     return $state->mark_choice($var) unless $var->bound_stream->is_exhausted;
  80   }
  81   $self->return_from_run(undef);
  82 }
  83
  84 sub then {
  85   my ($self, $then) = @_;
  86   $self->but(next_op => $then);
  87 }
  88
  89 sub return_from_run {
  90   my (undef, $return) = @_;
  91   (our $Nonlocal_Return)->($return);
  92 }
  93
  94 sub run {
  95   my ($state) = @_;
  96   with_return {
  97     my ($return) = @_;
  98     local our $Nonlocal_Return = $return;
  99     while (my $op = $state->next_op) {
 100       $state = $op->run($state);
 101     }
 102     return $state;
 103   }
 104 }
 105
 106 sub push_backtrack {
 107   $_[0]->then(DX::Op::FromCode->new(code => sub { $_[1]->backtrack }));
 108 }
 109
 110 sub but {
 111   my ($self, @but) = @_;
 112   $self->new(%$self, @but);
 113 }
 114
 115 sub pop_return_stack {
 116   my ($self) = @_;
 117   my @stack = @{$self->return_stack};
 118   my $top = pop @stack;
 119   $self->but(return_stack => \@stack, next_op => $top);
 120 }
 121
 122 sub push_return_then {
 123   my ($self, $return, $then) = @_;
 124   $self->but(
 125     return_stack => [ @{$self->return_stack}, $return ],
 126     next_op => $then
 127   );
 128 }
 129
 130 1;