File Coverage

blib/lib/MarpaX/Languages/ECMAScript/AST/Grammar/Base.pm

Criterion	Covered	Total	%
statement	59	175	33.7
branch	3	44	6.8
condition	0	28	0.0
subroutine	19	27	70.3
pod	17	17	100.0
total	98	291	33.6

use strict;
use warnings FATAL => 'all';

package MarpaX::Languages::ECMAScript::AST::Grammar::Base;
use MarpaX::Languages::ECMAScript::AST::Util qw/:all/;
use MarpaX::Languages::ECMAScript::AST::Impl qw//;
use Log::Any qw/$log/;
use constant SEARCH_KEYWORD_IN_GRAMMAR => '# DO NOT REMOVE NOR MODIFY THIS LINE';
use MarpaX::Languages::ECMAScript::AST::Exceptions qw/:all/;

# ABSTRACT: ECMAScript, grammars base package

our $VERSION = '0.018'; # VERSION

#
# Note: because this module is usually subclasses, internal methods are called
# using _method($self, ...) instead of $self->_method(...)
#


sub new {
  my ($class, $spec) = @_;

  InternalError(error => 'Missing ECMAScript specification') if (! defined($spec));

  my $self  = {
      _content        => $class->make_content($spec),
      _grammar_option => $class->make_grammar_option($spec),
      _recce_option   => $class->make_recce_option($spec),
  };

  bless($self, $class);

  return $self;
}


sub content {
    my ($self) = @_;
    return $self->{_content};
}


sub make_content {
    my ($class, $spec) = @_;

    my $content = $class->make_grammar_content;

    #
    # Too painful to write MarpaX::Languages::ECMAScript::AST::Grammar::${spec}::CharacterClasses::IsSomething
    # so I change it on-the-fly here
    #
    if ($spec eq 'ECMAScript-262-5') {
	$spec = 'ECMAScript_262_5';
    }
    my $characterClass = "\\p{MarpaX::Languages::ECMAScript::AST::Grammar::${spec}::CharacterClasses::Is";
    $content =~ s/\\p\{Is/$characterClass/g;

    return $content;
}


sub extract {
    my ($self) = @_;
    my $rc = '';

    my $content = $self->content;
    my $index = index($content, SEARCH_KEYWORD_IN_GRAMMAR);
    if ($index >= 0) {
      $rc = substr($content, $index);
      $rc =~ s/\baction[ \t]*=>[ \t]*\w+//g;
      $rc =~ s/(__\w+)[ \t]*::=[ \t]*/$1 ~ /g;
    }

    return $rc;
}


sub make_grammar_option {
    my ($class, $spec) = @_;
    return {bless_package => $class->make_bless_package,
	    source        => \$class->make_content($spec, $class->make_grammar_content)};
}


sub make_grammar_content {
    my ($class) = @_;
    return undef;
}


sub make_bless_package {
    my ($class) = @_;
    return $class;
}


sub grammar_option {
    my ($self) = @_;
    return $self->{_grammar_option};
}


sub recce_option {
    my ($self) = @_;
    return $self->{_recce_option};
}


sub make_recce_option {
    my ($class, $spec) = @_;
    return {ranking_method => $class->make_ranking_method,
            semantics_package => $class->make_semantics_package,
            too_many_earley_items => $class->make_too_many_earley_items};
}


sub make_ranking_method {
    my ($class) = @_;
    return 'high_rule_only';
}


sub make_semantics_package {
    my ($class) = @_;
    return join('::', __PACKAGE__, 'DefaultSemanticsPackage');
}


sub make_too_many_earley_items {
    my ($class) = @_;
    return 0;
}


sub _callback {
  my ($self, $source, $pos, $max, $impl, $callbackp, $originalErrorString, @args) = @_;

  my $rc = $pos;

  eval {$rc = &$callbackp(@args, $source, $pos, $max, $impl)};
  if ($@) {
    my $callbackErrorString = $@;
    my $line_columnp;
    eval {$line_columnp = lineAndCol($impl)};
    my $context = _context($self, $impl);
    #
    # Now we can destroy the recognizer
    #
    $impl->destroy_R;
    if (! $@) {
      if (defined($originalErrorString) && $originalErrorString) {
        SyntaxError(error => sprintf("%s\n%s\n\n%s%s", $originalErrorString, $callbackErrorString, showLineAndCol(@{$line_columnp}, $source), $context));
      } else {
        SyntaxError(error => sprintf("%s\n\n%s%s", $callbackErrorString, showLineAndCol(@{$line_columnp}, $source), $context));
      }
    } else {
      if (defined($originalErrorString) && $originalErrorString) {
        SyntaxError(error => sprintf("%s\n%s\n%s", $originalErrorString, $callbackErrorString, $context));
      } else {
        SyntaxError(error => sprintf("%s\n%s", $callbackErrorString, $context));
      }
    }
  }

  return $rc;
}

sub parse {
  my ($self, $source, $impl, $optionsp, $start, $length) = @_;

  $optionsp //= {};
  my $callbackp = $optionsp->{callback};
  my $callbackargsp = $optionsp->{callbackargs} // [];
  my @callbackargs = @{$callbackargsp};
  my $failurep = $optionsp->{failure};
  my $failureargsp = $optionsp->{failureargs} // [];
  my @failureargs = @{$failureargsp};
  my $endp = $optionsp->{end};
  my $endargsp = $optionsp->{endargs} // [];
  my @endargs = @{$endargsp};

  $start //= 0;
  $length //= -1;

  my $sourceMaxPos = length($source) - 1;
  if ($start < 0) {
      $start += $sourceMaxPos + 1;
  }
  my $max = ($length < 0) ? ($length + $sourceMaxPos + 1) : ($start + $length);

  my $pos = $start;
  my $stop;
  my $newpos;

  #
  # Create a recognizer
  #
  $impl->make_R;
  #
  # Lexer can fail
  #
  eval {$newpos = $impl->read(\$source, $pos, $length)};
  if ($@) {
    #
    # Failure callback
    #
    if (defined($failurep)) {
      $pos = _callback($self, $source, $pos, $max, $impl, $failurep, $@, @failureargs);
    } else {
      my $line_columnp = lineAndCol($impl);
      my $context = _context($self, $impl);
      $impl->destroy_R;
      SyntaxError(error => sprintf("%s\n\n%s%s", $@, showLineAndCol(@{$line_columnp}, $source), $context));
    }
  } else {
    $pos = $newpos;
  }
  do {
    #
    # Events
    #
    if (defined($callbackp)) {
      $pos = _callback($self, $source, $pos, $max, $impl, $callbackp, undef, @callbackargs);
    }
    #
    # Lexer can fail
    #
    eval {$newpos = $impl->resume($pos)};
    if ($@) {
      if (defined($failurep)) {
        #
        # Failure callback
        #
        $pos = _callback($self, $source, $pos, $max, $impl, $failurep, $@, @failureargs);
      } else {
        my $line_columnp = lineAndCol($impl);
	my $context = _context($self, $impl);
	$impl->destroy_R;
        SyntaxError(error => sprintf("%s\n\n%s%s", $@, showLineAndCol(@{$line_columnp}, $source), $context));
      }
    } else {
      $pos = $newpos;
    }
  } while ($pos <= $max);

  if (defined($endp)) {
    #
    # End callback
    #
      _callback($self, $source, $pos, $max, $impl, $endp, undef, @endargs);
  }

  return $self;
}


sub value {
  my ($self, $impl, $optionsp) = @_;

  $optionsp //= {};
  my $traverserp = $optionsp->{traverser};
  my $traverserscratchpadp = $optionsp->{traverserscratchpad} // {};

  my $asf = defined($traverserp) ? Marpa::R2::ASF->new({slr => $impl->R}) : undef;
  my $rc = (defined($asf) ? $asf->traverse($traverserscratchpadp, $traverserp) : $impl->value()) || do {
    my $lastExpression = _show_last_expression($self, $impl);
    $impl->destroy_R;
    InternalError(error => sprintf('%s', $lastExpression))
  };

  if (! defined($rc)) {
      $impl->destroy_R;
      InternalError(error => 'Undefined parse tree value');
  }
  if ((! defined($asf)) && defined(my $rc2 = $impl->value())) {
      $impl->destroy_R;
      InternalError(error => 'More than one parse tree value');
  }
  $impl->destroy_R;

  return ${$rc};
}

# ----------------------------------------------------------------------------------------

sub _context {
    my ($self, $impl) = @_;

    my $context = $log->is_debug ?
	sprintf("\n\nContext:\n\n%s", $impl->show_progress()) :
	'';

    return $context;
}


# ----------------------------------------------------------------------------------------

sub getLexeme {
  my ($self, $lexemeHashp, $impl) = @_;

  my $rc = 0;
  #
  # Get paused lexeme
  #
  my $lexeme = $impl->pause_lexeme();
  if (defined($lexeme)) {
    $lexemeHashp->{name} = $lexeme;
    ($lexemeHashp->{start}, $lexemeHashp->{length}) = $impl->pause_span();
    ($lexemeHashp->{line}, $lexemeHashp->{column}) = $impl->line_column($lexemeHashp->{start});
    $lexemeHashp->{value} = $impl->literal($lexemeHashp->{start}, $lexemeHashp->{length});
    $rc = 1;
  }

  return $rc;
}

# ----------------------------------------------------------------------------------------


# ----------------------------------------------------------------------------------------

sub getLastLexeme {
  my ($self, $lexemeHashp, $impl) = @_;

  my $rc = 0;
  #
  # Get last lexeme span
  #
  my ($start, $length) = lastLexemeSpan($impl);
  if (defined($start)) {
    ($lexemeHashp->{start}, $lexemeHashp->{length}) = ($start, $length);
    $lexemeHashp->{value} = $impl->literal($lexemeHashp->{start}, $lexemeHashp->{length});
    $rc = 1;
  }

  return $rc;
}

# ----------------------------------------------------------------------------------------

sub _show_last_expression {
  my ($self, $impl) = @_;

  my ($start, $end) = $impl->last_completed_range('SourceElement');
  return 'No source element was successfully parsed' if (! defined($start));
  my $lastExpression = $impl->range_to_string($start, $end);
  return "Last SourceElement successfully parsed was: $lastExpression";
}


1;

__END__