File Coverage

blib/lib/MarpaX/Simple/Rules.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

package MarpaX::Simple::Rules;
use strict;

our $VERSION='0.2.7';

use Marpa::XS;
use Data::Dumper;
use base 'Exporter';

our @EXPORT_OK = qw/parse_rules/;

sub Rules { my $m = shift; return { m => $m, rules => \@_ }; }
sub Rule { shift; return { @{$_[0]}, @{$_[2]}, @{$_[3]||[]} }; }
sub Rule2 { shift; return { @{$_[0]}, rhs => [], @{$_[2]||[]} }; }
sub Lhs { shift; return [lhs => $_[0]];}
sub Rhs { shift; return [rhs => $_[0]];}
sub Star { shift; return [rhs => [ $_[0] ], min => 0]; }
sub Plus { shift; return [rhs => [ $_[0] ], min => 1]; }
sub Names { shift; return [@_];}
sub Null { shift; return [rhs => []]; }
sub Action {
    my (undef, $arrow, $name) = @_;
    return [action => $name];
}

sub parse_rules {
    my ($string) = @_;

    my $grammar = Marpa::XS::Grammar->new({
        start   => 'Rules',
        actions => __PACKAGE__,
        rules => [
            { lhs => 'Rules',     rhs => [qw/Rule/],                                     action => 'Rules', min => 1 },

            { lhs => 'Rule',      rhs => [qw/Lhs DeclareOp Rhs Action/],                 action => 'Rule' },
            { lhs => 'Rule',      rhs => [qw/Lhs DeclareOp Action/],                     action => 'Rule2' },

            { lhs => 'Action',    rhs => [],                                             action => 'Action' },
            { lhs => 'Action',    rhs => [qw/ActionArrow ActionName/],                   action => 'Action' },
            { lhs => 'Action',    rhs => [qw/ActionArrow Name/],                         action => 'Action' },

            { lhs => 'Lhs',       rhs => [qw/Name/],                                     action => 'Lhs' },

            { lhs => 'Rhs',       rhs => [qw/Names/],                                    action => 'Rhs' },
            { lhs => 'Rhs',       rhs => [qw/Name Plus/],                                action => 'Plus' },
            { lhs => 'Rhs',       rhs => [qw/Name Star/],                                action => 'Star' },
            { lhs => 'Rhs',       rhs => [qw/Null/],                                     action => 'Null' },

            { lhs => 'Names',     rhs => [qw/Name/],                                     action => 'Names', min => 1 },
        ],
        terminals => [qw/DeclareOp ActionArrow Name ActionName Plus Star Null/],
    });
    $grammar->precompute;

    my $rec = Marpa::XS::Recognizer->new({grammar => $grammar});

    my @lines  = split /\n/, $string;
    if (!@lines) {
        return [];
    }

    my @terminals = (
        [ 'DeclareOp', '::=' ],
        [ 'ActionName', qr/(::(whatever|undef))/ ],
        [ 'Null', 'Null' ],
        [ 'ActionArrow', '=>' ],
        [ 'Plus', '\+' ],
        [ 'Star', '\*' ],
        [ 'Name', qr/\w+/, ],
    );

    my $nr = 1;

    LINE: for my $line (@lines) {
        my @tokens = split /\s+/, $line;

        TOKEN: for my $token (@tokens) {
            next if $token =~ m/^\s*$/;

            for my $t (@terminals) {
                if ($token =~ m/^($t->[1])/) {

                    if (!$rec->read($t->[0], $2 // $1)) {
                        if ($t->[0] eq 'DeclareOp') {
                            die "Error: Parse exhausted, " . (join ", ", @{$rec->terminals_expected})
                                . " expected before '::=' at line $nr";
                        }
                        else {
                            die "Error: Parse exhausted, " . (join ", ", @{$rec->terminals_expected})
                                . " expected at line $nr";
                        }
                    }

                    $token =~ s/$t->[1]//;

                    if ($token) {
                        redo TOKEN;
                    }

                    next TOKEN;
                }
            }

            die "Error: Found '$token', " . (join ", ", @{$rec->terminals_expected}) . " expected at line $nr";
        }
    }
    continue {
        $nr++;
    }

    #if (grep {$_ eq 'DeclareOp'} @{$rec->terminals_expected}) {
    #print Dumper($rec->terminals_expected);
    #$nr--;
    #die "Input incomplete DeclareOp expected at line $nr";
    #}

    #$rec->end_input;

    my $parse_ref = $rec->value;

    if (!defined $parse_ref) {
        return [];
    }

    my $parse = $$parse_ref;

#    if (ref($parse->{m}{error}) eq 'ARRAY' && @{$parse->{m}{error}}) {
#        die join ": ", @{$parse->{m}{error}};
#    }
    return $parse->{rules};
}

1;

__END__