lib/DX/State.pm

   1 package DX::State;
   2
   3 use Return::MultiLevel qw(with_return);
   4 use DX::Op::FromCode;
   5 use Moo;
   6
   7 has next_op => (is => 'ro', required => 1);
   8
   9 has return_stack => (is => 'ro', required => 1);
  10
  11 has by_id => (is => 'ro', required => 1);
  12
  13 has scope => (is => 'ro', required => 1);
  14
  15 has last_choice => (is => 'ro', required => 1);
  16
  17 sub scope_var {
  18   my ($self, $name) = @_;
  19   $self->by_id->{$self->scope->{$name}};
  20 }
  21
  22 sub bind_stream_then {
  23   my ($self, $var, $stream, $then) = @_;
  24   warn "Binding ".$var->id." to $stream";
  25   my $bound = $var->with_stream($stream);
  26   $self->new(%$self,
  27     by_id => { %{$self->by_id}, $var->id => $bound },
  28     next_op => $then
  29   )->mark_choice($bound);
  30 }
  31
  32 sub mark_choice {
  33   my ($self, $var) = @_;
  34   $self->new(%$self,
  35     last_choice => [ $self, $var ]
  36   );
  37 }
  38
  39 sub backtrack {
  40   my ($self) = @_;
  41   my ($state, $var) = ($self);
  42   while (($state, $var) = @{$state->last_choice}) {
  43     $var->bound_value; $var->clear_bound_value;
  44     return $state->mark_choice($var) unless $var->bound_stream->is_exhausted;
  45   }
  46   if (our $No_Options_Handler) {
  47     $No_Options_Handler->(undef);
  48   }
  49   die "Out of options";
  50 }
  51
  52 sub then {
  53   my ($self, $then) = @_;
  54   $self->new(%$self, next_op => $then);
  55 }
  56
  57 sub select_next_op {
  58   my ($self) = @_;
  59   return $self->next_op || do {
  60     if (my @stack = @{$self->return_stack}) {
  61       my $top = pop @stack;
  62       DX::Op::FromCode->new(
  63         code => sub {
  64           $_[1]->new(%{$_[1]}, return_stack => \@stack, next_op => $top)
  65         }
  66       );
  67     } else {
  68       undef;
  69     }
  70   };
  71 }
  72
  73 sub run {
  74   my ($state) = @_;
  75   with_return {
  76     my ($return) = @_;
  77     local our $No_Options_Handler = $return;
  78     while (my $op = $state->select_next_op) {
  79       $state = $op->run($state);
  80     }
  81     return $state;
  82   }
  83 }
  84
  85 sub push_backtrack {
  86   $_[0]->then(DX::Op::FromCode->new(code => sub { $_[1]->backtrack }));
  87 }
  88
  89 1;