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