File Coverage

blib/lib/Blatte/Parser.pm

Criterion	Covered	Total	%
statement	341	366	93.1
branch	130	206	63.1
condition	3	9	33.3
subroutine	25	27	92.5
pod	4	22	18.1
total	503	630	79.8

package Blatte::Parser;

use strict;

use Blatte;
use Blatte::Syntax;
use Blatte::Ws;

use vars qw($identifier_regex);

$identifier_regex = qr/[A-Za-z][A-Za-z0-9_]*(?![A-Za-z0-9_])/;

sub new {
  my $type = shift;
  bless { special_forms => [\&define_expr,
                            \&set_expr,
                            \&lambda_expr,
                            \&any_let_expr,
                            \&if_expr,
                            \&cond_expr,
                            \&while_expr,
                            \&and_expr,
                            \&or_expr] }, $type;
}

sub add_special_form {
  my $self = shift;
  push(@{$self->{special_forms}}, @_);
}

sub parse {
  my($self, $input_arg) = @_;
  my $expr = $self->expr($input_arg);
  return undef unless defined($expr);
  sprintf("&Blatte::wrapws('%s',\n                %s)",
          &Blatte::wsof($expr), $expr->transform(16));
}

sub expr {
  my($self, $input_arg) = @_;

  my $input = $input_arg;
  if (ref($input)) {
    $input = $$input;
  }

  my $ws = &consume_whitespace(\$input);

  return undef if ($input eq '');

  my $syntax;

  if (substr($input, 0, 1) eq '{') {
    $input = substr($input, 1);

    $syntax = $self->special_form(\$input);
    $syntax = new Blatte::Syntax::List($self->list_subexprs(\$input))
        unless defined $syntax;

    &consume_whitespace(\$input);
    return undef if ($input eq '');
    return undef if (substr($input, 0, 1) ne '}');
    $input = substr($input, 1);
  } elsif ($input =~ /^\\\"([^\\]+|\\[^\"])*\\\"/g) {
    my $str = substr($input, 0, pos($input));
    $input = substr($input, pos($input));
    $str = substr($str, 2, length($str) - 4);
    $str =~ s/\\(.)/$1/g;
    $syntax = new Blatte::Syntax::Literal($str);
  } elsif ($input =~ /^\\($identifier_regex)/go) {
    my $name = $1;
    $input = substr($input, pos($input));
    $syntax = new Blatte::Syntax::VarRef($name);
  } elsif ($input =~ /^([^\\{}\s]+|\\[\\{}])+/g) {
    my $atom = substr($input, 0, pos($input));
    $input = substr($input, pos($input));
    $atom =~ s/\\(.)/$1/g;
    $syntax = new Blatte::Syntax::Literal($atom);
  } else {
    return undef;
  }

  if (ref($input_arg)) {
    $$input_arg = $input;
  }

  return &Blatte::wrapws($ws, $syntax);
}

sub list_subexprs {
  my($self, $input_arg) = @_;

  my $input = $input_arg;
  if (ref($input)) {
    $input = $$input_arg;
  }

  my @subexprs;
  while (1) {
    my $ws = &consume_whitespace(\$input);
    if ($input =~ /^\\($identifier_regex)=/go) {
      my $name = $1;
      $input = substr($input, pos($input));

      my $expr = $self->expr(\$input);
      return undef unless defined($expr);

      push(@subexprs,
           new Blatte::Syntax::Assignment($name, &Blatte::unwrapws($expr)));
    } else {
      $input = ($ws . $input);
      my $expr = $self->expr(\$input);
      last unless defined($expr);
      push(@subexprs, $expr);
    }
  }

  if (ref($input_arg)) {
    $$input_arg = $input;
  }

  return @subexprs;
}

sub special_form {
  my($self, $input_arg) = @_;

  my $input = $input_arg;
  if (ref($input)) {
    $input = $$input_arg;
  }

  my $syntax;
  foreach my $formfn (@{$self->{special_forms}}) {
    $syntax = &$formfn($self, \$input);
    last if defined($syntax);
  }

  return undef unless defined($syntax);

  if (ref($input_arg)) {
    $$input_arg = $input;
  }

  return $syntax;
}

sub define_expr {
  my($self, $input_arg) = @_;

  my $input = $input_arg;
  if (ref($input)) {
    $input = $$input;
  }

  my $syntax = $self->define_var_expr(\$input);
  $syntax = $self->define_fn_expr(\$input) unless defined($syntax);

  return undef unless defined($syntax);

  if (ref($input_arg)) {
    $$input_arg = $input;
  }

  return $syntax;
}

sub define_var_expr {
  my($self, $input_arg) = @_;

  my $input = $input_arg;
  if (ref($input)) {
    $input = $$input_arg;
  }

  &consume_whitespace(\$input);
  return undef unless ($input =~ /^\\define(?![A-Za-z0-9_])/);
  $input = substr($input, 7);

  &consume_whitespace(\$input);
  return undef unless ($input =~ /^\\($identifier_regex)/go);
  my $name = $1;
  $input = substr($input, pos($input));

  my $expr = $self->expr(\$input);
  return undef unless defined($expr);

  my $syntax = new Blatte::Syntax::DefineVar($name, $expr);

  if (ref($input_arg)) {
    $$input_arg = $input;
  }

  return $syntax;
}

sub define_fn_expr {
  my($self, $input_arg) = @_;

  my $input = $input_arg;
  if (ref($input)) {
    $input = $$input_arg;
  }

  &consume_whitespace(\$input);
  return undef unless ($input =~ /^\\define(?![A-Za-z0-9_])/);
  $input = substr($input, 7);

  &consume_whitespace(\$input);
  if (($input eq '') || (substr($input, 0, 1) ne '{')) {
    return undef;
  }
  $input = substr($input, 1);

  &consume_whitespace(\$input);
  return undef unless ($input =~ /^\\($identifier_regex)/go);
  my $name = $1;
  $input = substr($input, pos($input));

  my @params = $self->params(\$input);

  &consume_whitespace(\$input);
  if (($input eq '') || (substr($input, 0, 1) ne '}')) {
    return undef;
  }
  $input = substr($input, 1);

  my @exprs = $self->exprs(\$input);

  my $syntax = new Blatte::Syntax::DefineFn($name, \@params, \@exprs);

  if (ref($input_arg)) {
    $$input_arg = $input;
  }

  return $syntax;
}

sub set_expr {
  my($self, $input_arg) = @_;

  my $input = $input_arg;
  if (ref($input)) {
    $input = $$input_arg;
  }

  &consume_whitespace(\$input);
  return undef unless ($input =~ /^\\set!(?![A-Za-z0-9_])/);
  $input = substr($input, 5);

  &consume_whitespace(\$input);
  return undef unless ($input =~ /^\\($identifier_regex)/go);
  my $name = $1;
  $input = substr($input, pos($input));

  my $expr = $self->expr(\$input);
  return undef unless defined($expr);

  my $syntax = new Blatte::Syntax::SetVar($name, $expr);

  if (ref($input_arg)) {
    $$input_arg = $input;
  }

  return $syntax;
}

sub lambda_expr {
  my($self, $input_arg) = @_;

  my $input = $input_arg;
  if (ref($input)) {
    $input = $$input_arg;
  }

  &consume_whitespace(\$input);
  return undef unless ($input =~ /^\\lambda(?![A-Za-z0-9_])/);

  $input = substr($input, 7);

  &consume_whitespace(\$input);
  if (($input eq '') || (substr($input, 0, 1) ne '{')) {
    return undef;
  }
  $input = substr($input, 1);

  my @params = $self->params(\$input);

  &consume_whitespace(\$input);
  return undef if ($input eq '');
  return undef if (substr($input, 0, 1) ne '}');
  $input = substr($input, 1);

  my @exprs;
  while (defined(my $expr = $self->expr(\$input))) {
    push(@exprs, $expr);
  }

  my $syntax = new Blatte::Syntax::Lambda(\@params, \@exprs);

  if (ref($input_arg)) {
    $$input_arg = $input;
  }

  return $syntax;
}

sub params {
  my($self, $input_arg) = @_;

  my $input = $input_arg;
  if (ref($input)) {
    $input = $$input_arg;
  }

  my @params;
  while (1) {
    &consume_whitespace(\$input);
    if ($input =~ /^\\($identifier_regex)/g) {
      my $name = $1;
      $input = substr($input, pos($input));
      push(@params, new Blatte::Syntax::Param::Positional($name));
    } elsif ($input =~ /^\\=($identifier_regex)/g) {
      my $name = $1;
      $input = substr($input, pos($input));
      push(@params, new Blatte::Syntax::Param::Named($name));
    } elsif ($input =~ /^\\&($identifier_regex)/g) {
      my $name = $1;
      $input = substr($input, pos($input));
      push(@params, new Blatte::Syntax::Param::Rest($name));
    } else {
      last;
    }
  }

  if (ref($input_arg)) {
    $$input_arg = $input;
  }

  return @params;
}

sub any_let_expr {
  my($self, $input_arg) = @_;

  my $input = $input_arg;
  if (ref($input)) {
    $input = $$input_arg;
  }

  &consume_whitespace(\$input);
  return undef unless ($input =~ /^\\(letrec|let\*?)(?![A-Za-z0-9_])/g);
  my $keyword = $1;
  $input = substr($input, pos($input));

  &consume_whitespace(\$input);
  return undef if ($input eq '');
  return undef if (substr($input, 0, 1) ne '{');
  $input = substr($input, 1);

  my @clauses = $self->let_clauses(\$input);
  return undef unless @clauses;

  &consume_whitespace(\$input);
  return undef if ($input eq '');
  return undef if (substr($input, 0, 1) ne '}');
  $input = substr($input, 1);

  my @exprs = $self->exprs(\$input);

  my $syntax;
  if ($keyword eq 'let') {
    $syntax = new Blatte::Syntax::Let(\@clauses, \@exprs);
  } elsif ($keyword eq 'let*') {
    $syntax = new Blatte::Syntax::LetStar(\@clauses, \@exprs);
  } else {                      # letrec
    $syntax = new Blatte::Syntax::Letrec(\@clauses, \@exprs);
  }

  if (ref($input_arg)) {
    $$input_arg = $input;
  }

  return $syntax;
}

sub let_clauses {
  my($self, $input_arg) = @_;

  my $input = $input_arg;
  if (ref($input)) {
    $input = $$input_arg;
  }

  my @clauses;
  while (1) {
    &consume_whitespace(\$input);
    last if ($input eq '');
    last if (substr($input, 0, 1) ne '{');
    $input = substr($input, 1);

    &consume_whitespace(\$input);
    return undef unless ($input =~ /^\\($identifier_regex)/go);
    my $name = $1;
    $input = substr($input, pos($input));

    my $expr = $self->expr(\$input);
    return undef unless defined($expr);

    &consume_whitespace(\$input);
    return undef if ($input eq '');
    return undef if (substr($input, 0, 1) ne '}');

    $input = substr($input, 1);

    push(@clauses, new Blatte::Syntax::LetClause($name, $expr));
  }

  if (ref($input_arg)) {
    $$input_arg = $input;
  }

  return @clauses;
}

sub if_expr {
  my($self, $input_arg) = @_;

  my $input = $input_arg;
  if (ref($input)) {
    $input = $$input_arg;
  }

  &consume_whitespace(\$input);
  return undef unless ($input =~ /^\\if(?![A-Za-z0-9_])/);
  $input = substr($input, 3);

  my $test = $self->expr(\$input);
  return undef unless defined($test);

  my $then = $self->expr(\$input);
  return undef unless defined($then);

  my @else = $self->exprs(\$input);

  my $syntax = new Blatte::Syntax::If($test, $then, @else);

  if (ref($input_arg)) {
    $$input_arg = $input;
  }

  return $syntax;
}

sub cond_expr {
  my($self, $input_arg) = @_;

  my $input = $input_arg;
  if (ref($input)) {
    $input = $$input_arg;
  }

  &consume_whitespace(\$input);
  return undef unless ($input =~ /^\\cond(?![A-Za-z0-9_])/);
  $input = substr($input, 5);

  my @clauses;
  while (1) {
    &consume_whitespace(\$input);
    last if ($input eq '');
    last if (substr($input, 0, 1) ne '{');
    $input = substr($input, 1);

    my $test = $self->expr(\$input);
    return undef unless defined($test);

    my @actions = $self->exprs(\$input);

    &consume_whitespace(\$input);
    return undef if ($input eq '');
    return undef if (substr($input, 0, 1) ne '}');
    $input = substr($input, 1);

    push(@clauses, new Blatte::Syntax::CondClause($test, @actions));
  }

  my $syntax = new Blatte::Syntax::Cond(@clauses);

  if (ref($input_arg)) {
    $$input_arg = $input;
  }

  return $syntax;
}

sub while_expr {
  my($self, $input_arg) = @_;

  my $input = $input_arg;
  if (ref($input)) {
    $input = $$input_arg;
  }

  &consume_whitespace(\$input);
  return undef unless ($input =~ /^\\while(?![A-Za-z0-9_])/);
  $input = substr($input, 6);

  my $test = $self->expr(\$input);
  return undef unless defined($test);

  my @body = $self->exprs(\$input);

  my $syntax = new Blatte::Syntax::While($test, @body);

  if (ref($input_arg)) {
    $$input_arg = $input;
  }

  return $syntax;
}

sub and_expr {
  my($self, $input_arg) = @_;

  my $input = $input_arg;
  if (ref($input)) {
    $input = $$input_arg;
  }

  &consume_whitespace(\$input);
  return undef unless ($input =~ /^\\and(?![A-Za-z0-9_])/);
  $input = substr($input, 4);

  my @exprs = $self->exprs(\$input);
  return undef unless @exprs;

  my $syntax = new Blatte::Syntax::And(@exprs);

  if (ref($input_arg)) {
    $$input_arg = $input;
  }

  return $syntax;
}

sub or_expr {
  my($self, $input_arg) = @_;

  my $input = $input_arg;
  if (ref($input)) {
    $input = $$input_arg;
  }

  &consume_whitespace(\$input);
  return undef unless ($input =~ /^\\or(?![A-Za-z0-9_])/);
  $input = substr($input, 4);

  my @exprs = $self->exprs(\$input);
  return undef unless @exprs;

  my $syntax = new Blatte::Syntax::Or(@exprs);

  if (ref($input_arg)) {
    $$input_arg = $input;
  }

  return $syntax;
}

sub exprs {
  my($self, $input_arg) = @_;

  my $input = $input_arg;
  if (ref($input)) {
    $input = $$input_arg;
  }

  my @exprs;
  while (1) {
    my $expr = $self->expr(\$input);
    last unless defined($expr);
    push(@exprs, $expr);
  }

  if (ref($input_arg)) {
    $$input_arg = $input;
  }

  return @exprs;
}

sub consume_whitespace {
  my $ref = shift;
  my $str = $$ref;
  my $ws = '';

  while (1) {
    if ($str =~ /^\s+/g) {
      $ws .= substr($str, 0, pos($str));
      $str = substr($str, pos($str));
    } elsif ($str =~ /^\\;.*/g) {
      $str = substr($str, pos($str));
    } elsif ($str =~ /^\\\//) {
      $ws = '';
      $str = substr($str, 2);
    } else {
      $$ref = $str;
      return $ws;
    }
  }
}

sub eof {
  my($self, $input_arg) = @_;

  my $input = $input_arg;
  if (ref($input)) {
    $input = $$input_arg;
  }

  &consume_whitespace(\$input);
  return undef unless ($input eq '');

  if (ref($input_arg)) {
    $$input_arg = $input;
  }

  return 1;
}

1;

__END__