randal.t

#!/usr/bin/perl
# Copyright 2012 Jeffrey Kegler
# This file is part of Marpa::XS.  Marpa::XS is free software: you can
# redistribute it and/or modify it under the terms of the GNU Lesser
# General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# Marpa::XS is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser
# General Public License along with Marpa::XS.  If not, see
# http://www.gnu.org/licenses/.

use 5.010;
use strict;
use warnings;
use English qw( -no_match_vars );

use Test::More tests => 5;
use lib 'tool/lib';
use Marpa::XS::Test;

BEGIN {
    Test::More::use_ok('Marpa::XS');
}

package Test_Grammar;

# This grammar is from Data::Dumper,
# which disagrees with Perl::Critic about proper
# use of quotes and with perltidy about
# formatting

#<<< no perltidy
##no critic (ValuesAndExpressions::ProhibitNoisyQuotes)

$Test_Grammar::MARPA_OPTIONS = [
    {
      'rules' => [
        {
          'action' => 'comment',
          'lhs' => 'comment:optional',
          'rhs' => [
            'comment'
          ]
        },
        {
          'lhs' => 'comment:optional',
          'rhs' => []
        },
        {
          'action' => 'show_perl_line',
          'lhs' => 'perl-line',
          'rhs' => [
            'perl-statements',
            'comment:optional'
          ]
        },
        {
          'action' => 'show_statement_sequence',
          'lhs' => 'perl-statements',
          'min' => 1,
          'rhs' => [
            'perl-statement'
          ],
          'separator' => 'semicolon'
        },
        {
          'action' => 'show_division',
          'lhs' => 'perl-statement',
          'rhs' => [
            'division'
          ]
        },
        {
          'action' => 'show_function_call',
          'lhs' => 'perl-statement',
          'rhs' => [
            'function-call'
          ]
        },
        {
          'action' => 'show_die',
          'lhs' => 'perl-statement',
          'rhs' => [
            'die:k0',
            'string-literal'
          ]
        },
        {
          'lhs' => 'division',
          'rhs' => [
            'expr',
            'division-sign',
            'expr'
          ]
        },
        {
          'lhs' => 'expr',
          'rhs' => [
            'function-call'
          ]
        },
        {
          'lhs' => 'expr',
          'rhs' => [
            'number'
          ]
        },
        {
          'action' => 'show_unary',
          'lhs' => 'function-call',
          'rhs' => [
            'unary-function-name',
            'argument'
          ]
        },
        {
          'action' => 'show_nullary',
          'lhs' => 'function-call',
          'rhs' => [
            'nullary-function-name'
          ]
        },
        {
          'lhs' => 'argument',
          'rhs' => [
            'pattern-match'
          ]
        }
      ],
      'start' => 'perl-line',
      'terminals' => [
        'die:k0',
        'unary-function-name',
        'nullary-function-name',
        'number',
        'semicolon',
        'division-sign',
        'pattern-match',
        'comment',
        'string-literal'
      ],
    }
  ];

my %regexes = (
    'die:k0'                => 'die',
    'unary-function-name'   => '(caller|eof|sin|localtime)',
    'nullary-function-name' => '(caller|eof|sin|time|localtime)',
    'number'                => '\\d+',
    'semicolon'             => ';',
    'division-sign'         => '[/]',
    'pattern-match'         => '[/][^/]*/',
    'comment'               => '[#].*',
    'string-literal'        => '"[^"]*"',
);

## use critic
#>>>
#

package main;

my @test_data = (
    [   'sin',
        q{sin  / 25 ; # / ; die "this dies!"},
        [ 'sin function call, die statement', 'division, comment' ]
    ],
    [ 'time', q{time  / 25 ; # / ; die "this dies!"}, ['division, comment'] ]
);

my $g = Marpa::XS::Grammar->new(
    {   warnings => 1,
        actions  => 'main',
    },
    @{$Test_Grammar::MARPA_OPTIONS}
);

$g->precompute();

TEST: for my $test_data (@test_data) {

    my ( $test_name, $test_input, $test_results ) = @{$test_data};
    my $recce = Marpa::XS::Recognizer->new( { grammar => $g } );

    my $input_length = length $test_input;
    pos $test_input = 0;

# Marpa::XS::Display
# name: Recognizer terminals_expected Synopsis

    my $terminals_expected = $recce->terminals_expected();

# Marpa::XS::Display::End

    for ( my $pos = 0; $pos < $input_length; $pos++ ) {
        TOKEN_TYPE: while ( my ( $token, $regex ) = each %regexes ) {
            next TOKEN_TYPE if not $token ~~ $terminals_expected;
            pos $test_input = $pos;
            next TOKEN_TYPE
                if not $test_input =~ m{ \G \s* (?<match>$regex) }xgms;

            $recce->alternative(
                $token,
                $+{match},   ## no critic (Variables::ProhibitPunctuationVars)
                ( ( pos $test_input ) - $pos )
            );

        } ## end while ( my ( $token, $regex ) = each %regexes )
        $recce->earleme_complete();
        $terminals_expected = $recce->terminals_expected();

    } ## end for ( my $pos = 0; $pos < $input_length; $pos++ )
    $recce->end_input();

    my @parses;
    while ( defined( my $value_ref = $recce->value() ) ) {
        my $value = $value_ref ? ${$value_ref} : 'No parse';
        push @parses, $value;
    }
    my $expected_parse_count = scalar @{$test_results};
    my $parse_count          = scalar @parses;
    Marpa::XS::Test::is( $parse_count, $expected_parse_count,
        "$test_name: Parse count" );

    my $expected = join "\n", sort @{$test_results};
    my $actual   = join "\n", sort @parses;
    Marpa::XS::Test::is( $actual, $expected, "$test_name: Parse match" );
} ## end for my $test_data (@test_data)

sub show_perl_line {
    shift;
    return join ', ', grep {defined} @_;
}

sub comment                 { return 'comment' }
sub show_statement_sequence { shift; return join q{, }, @_ }
sub show_division           { return 'division' }
sub show_function_call      { return $_[1] }
sub show_die                { return 'die statement' }
sub show_unary              { return $_[1] . ' function call' }
sub show_nullary            { return $_[1] . ' function call' }

1;    # In case used as "do" file