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 warn "assign: ${name}";
  41     unless (blessed($vars{$name})) {
  42       my $var = $vars{$name} = $state->allocate_var($name, $vars{$name});
  43       $by_id{$var->id} = $var;
  44     }
  45   }
  46   $state->but(
  47     by_id => \%by_id,
  48     scope => { %{$self->scope}, map +($_ => $vars{$_}->id), keys %vars }
  49   );
  50 }
  51
  52 sub bind_var_then {
  53   my ($self, $var, $value, $then) = @_;
  54   warn "Binding ".$var->id." to $value";
  55   my $bound = $var->with_value($value);
  56   $self->but(
  57     by_id => { %{$self->by_id}, $var->id => $bound },
  58     next_op => $then
  59   );
  60 }
  61
  62 sub bind_stream_then {
  63   my ($self, $var, $stream, $then) = @_;
  64   warn "Binding ".$var->id." to $stream";
  65   my $bound = $var->with_stream($stream);
  66   $self->but(
  67     by_id => { %{$self->by_id}, $var->id => $bound },
  68     next_op => $then
  69   )->mark_choice($bound);
  70 }
  71
  72 sub mark_choice {
  73   my ($self, $var) = @_;
  74   $self->but(last_choice => [ $self, $var ]);
  75 }
  76
  77 sub backtrack {
  78   my ($self) = @_;
  79   my ($state, $var) = ($self);
  80   while (($state, $var) = @{$state->last_choice}) {
  81     $var->bound_value; $var->clear_bound_value;
  82     return $state->mark_choice($var) unless $var->bound_stream->is_exhausted;
  83   }
  84   $self->return_from_run(undef);
  85 }
  86
  87 sub then {
  88   my ($self, $then) = @_;
  89   $self->but(next_op => $then);
  90 }
  91
  92 sub return_from_run {
  93   my (undef, $return) = @_;
  94   (our $Nonlocal_Return)->($return);
  95 }
  96
  97 sub run {
  98   my ($state) = @_;
  99   with_return {
 100     my ($return) = @_;
 101     local our $Nonlocal_Return = $return;
 102     while (my $op = $state->next_op) {
 103 #::Dwarn($op);
 104       $state = $op->run($state);
 105     }
 106     return $state;
 107   }
 108 }
 109
 110 sub push_backtrack {
 111   $_[0]->then(DX::Op::FromCode->new(code => sub { $_[1]->backtrack }));
 112 }
 113
 114 sub but {
 115   my ($self, @but) = @_;
 116   $self->new(%$self, @but);
 117 }
 118
 119 sub pop_return_stack {
 120   my ($self) = @_;
 121   my @stack = @{$self->return_stack};
 122   my $top = pop @stack;
 123   $self->but(return_stack => \@stack, next_op => $top);
 124 }
 125
 126 sub push_return_then {
 127   my ($self, $return, $then) = @_;
 128   $self->but(
 129     return_stack => [ @{$self->return_stack}, $return ],
 130     next_op => $then
 131   );
 132 }
 133
 134 1;