Perlでパーサーコンビネータもどき

HaskellのMonadをJavaScriptで実装するとしたら - ラシウラ
を参考にほとんど写経.

#!/usr/bin/env perl
use strict;
use warnings;

sub parse {
  my ($parser, $input) = @_;
  return $parser->({
      result => [],
      source => $input,
      index  => 0,
    });
}

sub bind {
  my ($src, $dst) = @_;
  return sub {
    my $pstate = shift;
    my $nstate = $src->($pstate);
    return &fail($nstate) unless $nstate;
    return $dst->($nstate->{result})->($nstate);
  };
}

sub return {
  my $value = shift;
  return sub {
    my $pstate = shift;
    my $nstate;
    %$nstate          = %$pstate;
    $nstate->{result} = $value;
    return $nstate;
  };
}

sub fail { return; }

sub char {
  my $ch = shift;
  return sub {
    my $pstate = shift;
    if (substr($pstate->{source}, $pstate->{index}, 1) eq $ch) {
      my $nstate;
      %$nstate          = %$pstate;
      $nstate->{index}  = $pstate->{index} + 1;
      $nstate->{result} = $ch;
      return $nstate;
    } else {
      &fail;
    }
  }
}

sub many
{
  my $parser = shift;
  return sub {
    my $pstate  = shift;
    my $current = $pstate;
    my $result;
    for(;;) {
      my $next = $parser->($current);
      if ($next) {
        $result .= $next->{result};
        $current = $next;
      } else {
        my $nstate;
        %$nstate          = %$current;
        $nstate->{result} = $result;
        return $nstate;
      }
    }
  };
}

sub orelse
{
  my ($p1, $p2) = @_;
  return sub {
    my $pstate = shift;
    return $p1->($pstate) || $p2->($pstate);
  };
}

実行例

my $manydParser = many(&bind(char('d'), sub {
      my $a = shift;
      return &return($a);
    }));

my $abcParser =
    &bind(char('a'), sub { my $a = shift;
    &bind(char('b'), sub { my $b = shift;
    &bind(char('c'), sub { my $c = shift;
    &return($a . $b . $c);
    }); }); });

print parse($manydParser,                     "ddda") ->{result}, "\n"; # "ddd"
print parse($abcParser,                       "abcd") ->{result}, "\n"; # "abc"
print parse($abcParser,                       "abd"),             "\n"; # undef
print parse(orelse($abcParser, $manydParser), "ddabd")->{result}, "\n"; # "dd"