File Coverage

blib/lib/Parse/Earley.pm

Criterion	Covered	Total	%
statement	163	232	70.2
branch	58	114	50.8
condition	25	60	41.6
subroutine	17	17	100.0
pod	0	11	0.0
total	263	434	60.6

package Parse::Earley;

#Parse::Earley
#By Luke Palmer
#Copyright (C) 2002, Luke Palmer. All rights reserved.
#This module is free software. It may used, redistributed, and/or modified
#under the terms of the Perl Artistic Licence:
#        http://www.perl.com/perl/misc/Artistic.html

use Text::Balanced qw( extract_quotelike extract_codeblock
                       extract_bracketed extract_multiple );
use Carp;

use strict;

our $VERSION = '0.15';
our $DEBUG;

sub new($)
{
    my $self = bless {
        rules => { },
        sets =>  { },           # Sparse array by pos()
        set =>   [ ],           # Not an index, rather, something to be pushed
        ncset => [ ],
        skip => qr/\s*/,
        no_code => undef,
    } => shift
}

sub pushset(\$$)
{
# rule lhs dot pos ref
    my ($self, $set) = @_;
    my $change = 0;
    for my $state (@$set) {
        my $s = $self->{sets}{$state->{pos}};
#        unless (grep { $_->{rule} == $state->{rule} &&
#                       $_->{lhs} eq $state->{lhs} &&
#                       $_->{dot} == $state->{dot} &&
#                       $_->{pos} == $state->{pos} &&
#                       $_->{ref} == $state->{ref} }
        unless (grep { $_ == $state }
                    @{$self->{sets}{$state->{pos}}} ) {
            push @{$self->{sets}{$state->{pos}}}, $state;
            $change++;
        }
    }
    return $change;
}

# XXX: This is a I simple processor: make it better
sub grammar(\$$)
{
    my ($self, $g) = @_;
    local $_ = $g;              # XXX: Pseudo hack. I don't know why I can't
                                # extract_multiple($g, ...)
    my @toks = extract_multiple($_, [
                   qr/[a-zA-Z_]\w*\s*:/,        # LHS
                   qr/[a-zA-Z_]\w*/,            # Nonterminal
                   sub { scalar extract_quotelike($_); },
                   sub { scalar extract_bracketed($_, '<>') },
                   sub { scalar extract_codeblock($_, '{}') },
                   qr/\|/,
                   qr/#.*/m,
                   ]);
    my @rulebuf;
    my $curule;
    my $errors;
    my $noskip_f;
    my $lineno;

    for (@toks)
    {
        $lineno++ for (/\n/g);

        my %cp = (line => $lineno);
        if ($noskip_f) {
            $noskip_f = 0;
            %cp = (%cp, noskip => 1);
        }

        s/^\s+//;
        s/\s+$//;

        if (/^(\w+)\s*:$/) {           # LHS
            push @{$self->{rules}{$curule}}, [ @rulebuf ];
            undef @rulebuf;
            $curule = $1;
        }
        elsif (/^\|$/) {
            push @{$self->{rules}{$curule}}, [ @rulebuf ];
            undef @rulebuf;
        }
        elsif (/^(\w+)$/) {           # Nonterminal
            push @rulebuf, { %cp,
                             match => $1,
                             type => 'nonterminal' };
        }
        elsif (/^['"]/) {         # Terminal
            push @rulebuf, { %cp,
                             match => eval "$_",
                             type => 'literal' };
        }
        elsif (/^q/) {
            push @rulebuf, { %cp,
                             match => eval "$_",
                             type => 'literal' };
        }
        elsif (/^\/(.*)\/$/ || /^m.(.*).$/) {
            push @rulebuf, { %cp,
                             match => qr/$1/,
                             type => 'regex' };
        }
        elsif (/^<\s*(.*)\s*>$/) {
            my $dir = $1;
            if ($dir eq 'noskip') {
                $noskip_f = 1;
            }
            else {
                $errors .= "Unrecognized directive: <$dir> at line $lineno\n";
            }
        }
        elsif (/^{/) {
            if ($self->{no_code}) {
                $errors .= "Code not allowed\n";
            }
            elsif (@rulebuf) {
                $rulebuf[$#rulebuf]{code} = eval "sub $_";
                $errors .= "$@\n" if $@;
            }
            else {
                $errors .= "Condition does not follow anything at line $lineno\n";
            }
        }
        elsif (/^#/ || /^\s*$/) {
        }
        else {
            $errors .= "Unrecognized pattern '$_' at line $lineno\n";
        }
    }
    push @{$self->{rules}{$curule}}, [ @rulebuf ];
    if ($errors) {
        croak $errors;
    }
    else {
        return 1;
    }
}

sub start(\$$)
{
    my ($self, $rule) = @_;
    my @newset;
    $self->{sets} = { };
    $self->{set} = [ ];
    $self->{ncset} = [ ];
    for (@{$self->{rules}{$rule}}) {
        push @newset, { rule => $_,
                        lhs  => $rule,
                        dot  => 0,
                        pos  => 0,
                        ref  => 0 };
    }
    push @{$self->{ncset}}, @newset;
    $self->pushset(\@newset);
}

sub advance(\$$)
{
    my ($self, $str) = @_;

    $self->pushset($self->{ncset});
    $self->{set} = $self->{ncset};
    $self->{ncset} = [ ];

    for (@{$self->{set}}) {
        #This is the main huffmanized switch.
        #The heart of the algorithm is here.

        my $p = $_->{rule}[$_->{dot}];
        if ($p) {
            if ($p->{type} eq 'nonterminal') {
                $self->predict($_);
            }
            else {
                $self->scan($_, $str);
            }
        }
        else {
            $self->complete($_);
        }
    }

    if ($DEBUG) {
        my $displen = 7;
        my $sp = ' ' x 4;
      for (qw(set ncset)) {
        print /nc/ ? 'advance(): NEXT SET' : 'advance(): CURRENT SET';
        print "\n";
        for my $state (@{$self->{$_}}) {
            print $sp;
            my (@p);
            if ($state->{pos} < $displen) {
                $p[0] = substr($str, 0, $state->{pos});
            }
            else {
                $p[0] = substr($str, $state->{pos}-$displen, $displen);
            }
            $p[1] = substr($str, $state->{pos}, 5);
            s/(.)/ord($1)<32 || ord($1)>127 ? '.' : $1/seg for @p;
            printf "\%${displen}s * \%-${displen}s\%s", $p[0], $p[1], $sp;
            print "($state->{pos}) $state->{lhs}: ";
            for (my $i= 0; $i < @{$state->{rule}} || $i <= $state->{dot}; $i++){
                if ($state->{dot} == $i) {
                    print "* ";
                }
                if (exists $state->{rule}[$i]) {
                    my $t = $state->{rule}[$i]{type};
                    my $p = $state->{rule}[$i]{match};
                    if ($t eq 'literal') {
                        print "'$p' "
                    }
                    elsif ($t eq 'regex') {
                        $p =~ s/^.*?://;        # Get rid of the qr// stuff
                        $p =~ s/\)$//;
                        print "/$p/ "

                    }
                    else {
                        print "$p ";
                    }
                }
            }
            print "($state->{ref})\n";
        }
      }

    }

}

#This function checks for matching the entire input. Sub matches
#are seldom of use, and so they are discarded (as they make the
#parse graph needlessly huge).
sub matches(\$$$)
{
    my ($self, $str, $rule) = @_;
    $str =~ s/$self->{skip}$//;
    my $cset = $self->{sets}{length($str)} or return;
    return grep { $_->{lhs} eq $rule &&
                  $_->{dot} == @{$_->{rule}} &&
                  $_->{ref} == 0 }
                          @$cset;
}

sub matches_all(\$$$)
{
    my ($self, $str, $rule) = @_;
    my $cset = $self->{ncset};
    unless (@$cset) {
        return $self->matches($str, $rule);
    }
    return;
}

sub fails(\$$$)
{
    my ($self, $str, $rule) = @_;
    if ($self->matches($str, $rule)) {
        return 0;
    }
    else {
        return @{$self->{set}} ? 0 : 1;
    }
}

sub predict(\$$)
{
    my ($self, $state) = @_;
    my $cset = $self->{set};
    my $p = $state->{rule}[$state->{dot}];

    unless ($self->{rules}{$p->{match}}) {
        croak "No definition for nonterminal '$p->{match}'\n";
    }
    my @newset = @{$self->{rules}{$p->{match}}};
    @newset = map {
        my $m = $_;
        unless (grep { $_->{rule} == $m &&
                       $_->{lhs} eq $p->{match} &&
                       $_->{dot} == 0 &&
                       $_->{pos} == $state->{pos} &&
                       $_->{ref} == $state->{pos} } @$cset) {
                    { rule => $m,
                      lhs  => $p->{match},
                      dot  => 0,
                      pos  => $state->{pos},
                      ref  => $state->{pos} }
        }
        else {
            ()
        }
    } @newset;
    push @$cset, @newset;
    $self->pushset(\@newset);
}


sub scan(\$$$)
{
    my ($self, $state, $str) = @_;
    my $cset = $self->{set};
    my $skipos = $state->{pos};
    my $p = $state->{rule}[$state->{dot}];

    unless ($state->{rule}[$state->{dot}]{noskip}) {
        pos $str = $skipos;
        $str =~ /\G$self->{skip}/g;      # Terminal Seperator!
        $skipos = pos $str;
    }

    if ($p->{type} eq 'literal') {
        my $tok = substr($str, $skipos, length $p->{match});
        my $res = 1;
        if ($p->{code}) {
            local $_ = $tok;
            $res = eval { $p->{code}() };
            croak "$@ near line $p->{line} of grammar\n" if $@;
        }
        if ($res and $tok eq $p->{match}){
            my $push = {
                rule => $state->{rule},
                lhs => $state->{lhs},
                dot => $state->{dot}+1,
                pos => $skipos+length $p->{match},
                ref => $state->{ref},
                tok => $tok ,
                left => [ $state ] };
            unless (grep {
                $_->{rule} == $push->{rule} &&
                $_->{lhs} eq $push->{lhs} &&
                $_->{dot} == $push->{dot} &&
                $_->{pos} == $push->{pos} &&
                $_->{ref} == $push->{ref} } @{$self->{ncset}} ) {
                    push @{$self->{ncset}}, $push;
#                    push @{$self->{sets}{$push->{pos}}}, $push;
            }
        }
    }
    elsif ($p->{type} eq 'regex') {
        pos $str = $skipos;
        if ($str =~ /\G($p->{match})/g) {
            my $tok = $1;
            if ($p->{code}) {
                local $_ = $tok;
                my $res = eval { $p->{code}() };
                croak "$@ near line $p->{line} of grammar\n" if $@;
                return unless $res;     # Should make this some sort of break
            }
            my $push = {
                rule => $state->{rule},
                lhs => $state->{lhs},
                dot => $state->{dot}+1,
                pos => pos $str,
                ref => $state->{ref},
                tok => $tok,
                left => [ $state ] };
            unless (grep {
                $_->{rule} == $push->{rule} &&
                $_->{lhs} eq $push->{lhs} &&
                $_->{dot} == $push->{dot} &&
                $_->{pos} == $push->{pos} &&
                $_->{ref} == $push->{ref} } @{$self->{ncset}} ) {
                    push @{$self->{ncset}}, $push;
                    push @{$self->{sets}{$push->{pos}}}, $push;
            }
        }
    }
}

sub complete(\$$)
{
    my ($self, $state) = @_;
    my $cset = $self->{set};
    my @newset = grep {
                    (exists $_->{rule}[$_->{dot}] &&
                     $_->{rule}[$_->{dot}]{match}) eq $state->{lhs} }
                    @{$self->{sets}{$state->{ref}}};
    my @reval;
    @newset = map {
        my $m = $_;
        my @g;
        unless (@g = grep { $_->{rule} == $m->{rule} &&
                       $_->{lhs} eq $m->{lhs} &&
                       $_->{dot} == $m->{dot}+1 &&
                       $_->{pos} == $state->{pos} &&
                       $_->{ref} == $m->{ref} } @$cset) {

                    my $push = { rule => $m->{rule},
                                 lhs  => $m->{lhs},
                                 dot  => $m->{dot}+1,
                                 pos  => $state->{pos},
                                 ref  => $m->{ref},
                                 down => [ $state ],
                                 left => [ $m ],
                               };
                    if ($m->{rule}[$m->{dot}]{code}) {
                        local $_ = $state;
                        my $res = eval { $m->{rule}[$m->{dot}]{code}() };
                        croak "$@ near line $m->{rule}[$m->{dot}]{line} "
                             ."of grammar\n" if $@;
                        $res ? $push : ()
                    }
                    else {
                        $push
                    }
        }
        else {
            for (@g) {
                unless (grep { $_ == $state } @{$_->{down}} and
                        grep { $_ == $m } @{$_->{left}}) {
                    my $succ = 1;
                    if ($m->{rule}[$m->{dot}]{code}) {
                        my $left;
                        local $_ = $state;
                        $succ = eval { $m->{rule}[$m->{dot}]{code}() };
                        croak "$@ near line $m->{rule}[$m->{dot}]{line} "
                             ."of grammar\n" if $@;
                    }
                    if ($succ) {
                        push @{$_->{down}}, $state;
                        push @{$_->{left}}, $m;
                    }
                }
            }
            ()
        }
    } @newset;
    push @$cset, @newset;
    $self->pushset(\@newset);
}

1;

__END__