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_var_then {
  23   my ($self, $var, $value, $then) = @_;
  24   warn "Binding ".$var->id." to $value";
  25   my $bound = $var->with_value($value);
  26   $self->but(
  27     by_id => { %{$self->by_id}, $var->id => $bound },
  28     next_op => $then
  29   );
  30 }
  31
  32 sub bind_stream_then {
  33   my ($self, $var, $stream, $then) = @_;
  34   warn "Binding ".$var->id." to $stream";
  35   my $bound = $var->with_stream($stream);
  36   $self->but(
  37     by_id => { %{$self->by_id}, $var->id => $bound },
  38     next_op => $then
  39   )->mark_choice($bound);
  40 }
  41
  42 sub mark_choice {
  43   my ($self, $var) = @_;
  44   $self->but(last_choice => [ $self, $var ]);
  45 }
  46
  47 sub backtrack {
  48   my ($self) = @_;
  49   my ($state, $var) = ($self);
  50   while (($state, $var) = @{$state->last_choice}) {
  51     $var->bound_value; $var->clear_bound_value;
  52     return $state->mark_choice($var) unless $var->bound_stream->is_exhausted;
  53   }
  54   $self->return_from_run(undef);
  55 }
  56
  57 sub then {
  58   my ($self, $then) = @_;
  59   $self->but(next_op => $then);
  60 }
  61
  62 sub return_from_run {
  63   my (undef, $return) = @_;
  64   (our $Nonlocal_Return)->($return);
  65 }
  66
  67 sub run {
  68   my ($state) = @_;
  69   with_return {
  70     my ($return) = @_;
  71     local our $Nonlocal_Return = $return;
  72     while (my $op = $state->next_op) {
  73       $state = $op->run($state);
  74     }
  75     return $state;
  76   }
  77 }
  78
  79 sub push_backtrack {
  80   $_[0]->then(DX::Op::FromCode->new(code => sub { $_[1]->backtrack }));
  81 }
  82
  83 sub but {
  84   my ($self, @but) = @_;
  85   $self->new(%$self, @but);
  86 }
  87
  88 sub pop_return_stack {
  89   my ($self) = @_;
  90   my @stack = @{$self->return_stack};
  91   my $top = pop @stack;
  92   $self->but(return_stack => \@stack, next_op => $top);
  93 }
  94
  95 sub push_return_then {
  96   my ($self, $return, $then) = @_;
  97   $self->but(
  98     return_stack => [ @{$self->return_stack}, $return ],
  99     next_op => $then
 100   );
 101 }
 102
 103 1;