Re: Perl6 grammar

[Sean O'Rourke]

Based on perlop(1) and the note at the end of apocalypse 3, here's a start
on a Parse::RecDescent grammar for Perl 6 expressions.  It does not handle
some variables; in particular, qq/${"foo"}/ won't fly.  It should handle
precedence and hyping when adding new operators in the "right way".  To
add a new operator with the same precedence as binary '+', you can do
something like

addsub_op: '=#$%'

and get the hyped '^=#$%' operator for free.  If you don't want it to be
hyped, you can do this:

_addsub_op: '=#$%'

If you want it to be unary prefix, but with the same precedence, you can
do this:

addsub: '=#$%' muldiv

Fire away!
/s

use Parse::RecDescent;
use Data::Dumper;
use strict;
$Data::Dumper::Terse = 1;
$Data::Dumper::Indent = 1;
use Term::ReadLine;

my $grammar = <<'END';
{
    use Regexp::Common;
}
<autotree>

# Literals:

literal: lit_int | lit_real | lit_string
lit_int:  /$RE{num}{int}/
lit_real: /$RE{num}{real}/
lit_string: <perl_quotelike>

# Variables:

variable: sv | av | hv
sv: '$' name

av: '@' name

hv: '%' name

cv: '&' name

name:     '{' name '}'
        | sv
        | /[\/\\^%&*\$\#@!_0-9]/
        | ('::')(?) <leftop: /[\w_]+/ '::' /[\w_]+/>

# operators/expressions

hype:   ('^')(?)

term:     '(' expr ')'
        | literal
        | variable

left_list:      left_list_op(?) term
left_list_op:   'left_list'

apply:          <leftop: left_list _apply_op left_list>
_apply_op:      hype apply_op
apply_op:       '.'

incr:             apply _incr_op
                | _incr_op apply
                | apply
_incr_op:         hype incr_op
incr_op:          '++' | '--'

pow:      <rightop: incr _pow_op incr>
_pow_op:  hype pow_op
pow_op:   '**'

misc_unary:       _misc_unary_op(?) pow
_misc_unary_op:   hype misc_unary_op
misc_unary_op:    '!' | '~' | '\\' | '+' | '-'

match:          <leftop: misc_unary _match_op misc_unary>
_match_op:      hype match_op
match_op:       '=~' | '!~'

muldiv:         <leftop: match _muldiv_op match>
_muldiv_op:     hype muldiv_op
muldiv_op:      '*' | '/' | '%' | 'x'

addsub:         <leftop: muldiv _addsub_op muldiv>
_addsub_op:     hype addsub_op
addsub_op:      '+' | '-' | '_'

bitshift:       <leftop: addsub _bitshift_op addsub>
_bitshift_op:   hype bitshift_op
bitshift_op:    '<<' | '>>'

named_unary:    named_unary_op(s?) bitshift
named_unary_op: 'named_unary'

compare:          <leftop: named_unary _compare_op named_unary>
_compare_op:      hype compare_op
compare_op:       '==' | '!=' | '<'  | '>'  | '<=' | '>=' | '<=>'
                | 'eq' | 'ne' | 'lt' | 'gt' | 'le' | 'ge' | 'cmp'

bitand:         <leftop: compare _bitand_op compare>
_bitand_op:     hype bitand_op
bitand_op:      '&'

bitor:          <leftop: bitand _bitor_op bitand>
_bitor_op:      hype bitor_op
bitor_op:       '|' | '^'

logand:         <leftop: bitor _logand_op bitor>
_logand_op:     hype logand_op
logand_op:      '&'

logor:          <leftop: logand _logor_op logand>
_logor_op:      hype logor_op
logor_op:       '|' | '^'

range:    logor (range_op logor)(?)
range_op: '...' | '..'

ternary:  range ('?' ternary ':' ternary)(?)

assign:           <rightop: ternary _assign_op ternary>
_assign_op:       '^' assign_op
assign_op:        assignable_op(?) '='
assignable_op:    logand_op | logor_op
                | bitand_op | bitor_op | bitshift_op
                | addsub_op | muldiv_op | pow_op
                | '!'

comma:    <leftop: assign comma_op assign>
comma_op: ',' | '=>'

right_list:      right_list_op(s?) comma
right_list_op: 'not' | 'right_list'

log_AND:  <leftop: right_list _log_AND_op right_list>
_log_AND_op: hype log_AND_op
log_AND_op: 'and'

log_OR:   <leftop: log_AND _log_OR_op log_AND>
_log_OR_op: hype log_OR_op
log_OR_op: 'or' | 'xor'

expr:     log_OR

END

my $parser = new Parse::RecDescent $grammar or die $!;

sub simplify {
    my $self = shift;
    if (!ref $self) {
        return $self;
    } elsif (ref $self eq 'ARRAY') {
        return join ' ', map { simplify($_) } @$self;
    } elsif (exists $self->{__done__}) {
        return '';
    } else {
        $self->{__done__} = 1;
        if (exists $self->{__VALUE__}) {
            return $self->{__VALUE__};
        }
        if ($self->{__RULE__} eq 'hype') {
            return $self->{"'^'"}[0];
        }
        my @things = grep /\S/, map { simplify($self->{$_}) }
            grep !/__(?:RULE|done)__/, keys %$self;
        if (@things == 1) {
            return $things[0];
        } else {
            return "($self->{__RULE__} ".(join ' ', @things).')';
        }
    }
}

my $term = new Term::ReadLine;
while (defined(local $_ = $term->readline('> '))) {
    if (/^:(.*)/) {
        print eval $1;
    } else {
        my $result = $parser->expr($_);
        if ($::USE_DUMPER) {
            print Dumper $result;
        } else {
            if ($result) {
                print simplify($result), "\n";
            } else {
                print "parse error\n";
            }
        }
    }
    print "\n";
}