/usr/local/CPAN/v6-alpha/Pugs/Grammar/P6Rule.pm

• package Pugs::Grammar::P6Rule
  • code
  • literal
  • metasyntax
• EOF

# this file was extracted from the P6 version in Pugs-Compiler-Rule

package  Pugs::Grammar::P6Rule;
use strict;
use warnings;

use Pugs::Compiler::Rule;
use Pugs::Compiler::Token;
use Pugs::Compiler::Regex;
use base 'Pugs::Grammar::Base';
use Pugs::Runtime::Match::Ratchet; # overload doesn't work without this ???

our @rule_terms;

# reuse some subs
  use Pugs::Grammar::Rule; 
  # XXX - this doesn't work:
  #       "Can't call method "no_match" on an undefined value"
  #*code       = &Pugs::Grammar::Rule::code;
  #*literal    = &Pugs::Grammar::Rule::literal;
  #*metasyntax = &Pugs::Grammar::Rule::metasyntax;
  sub code       { Pugs::Grammar::Rule::code(@_) }
  sub literal    { Pugs::Grammar::Rule::literal(@_) }
  sub metasyntax { Pugs::Grammar::Rule::metasyntax(@_) }
  push @rule_terms, 'metasyntax';

*ws = Pugs::Compiler::RegexPerl5->compile(q(^((?:\\s|\\#(?-s:.)*)+)), { P5 => 0 })->code;
*variable = Pugs::Compiler::RegexPerl5->compile(q(^([\\$\\%\\@](?:(?:\\:\\:)?[_[:alnum:]]+)+)), { P5 => 0 })->code;
*positional_variable = Pugs::Compiler::RegexPerl5->compile(q(^([\\$\\%\\@]\\^(?:[_[:alnum:]]+))), { P5 => 0 })->code;
*ident = Pugs::Compiler::RegexPerl5->compile(q(^((?:(?:\\:\\:)?[_[:alnum:]]+)+)), { P5 => 0 })->code;
*num_variable = Pugs::Compiler::RegexPerl5->compile(q(^(?:\\$[[:digit:]]+)), { P5 => 0 })->code;
*dot = Pugs::Compiler::Regex->compile(q(
                \\.    
                        
                { return { 'dot' => 1 ,} }
        ))->code;
*plain_text = Pugs::Compiler::Regex->compile(q(
                <alnum> | \\, | \\; | \\_ | \\/ | \\~ | \\" | \\' | \\=

                { return { 'constant' => $() ,} }
        ))->code;
*special_char = Pugs::Compiler::Regex->compile(q(
                \\\\ .

                { return { special_char => $(), } } 
        ))->code;
*non_capturing_group = Pugs::Compiler::Regex->compile(q(
                \\[ <rule> \\] 
                  
                { return $_[0]{rule}() }
        ))->code;
*closure_rule = Pugs::Compiler::Regex->compile(q(
                <code>
                        
                { return { closure => $_[0]{code}() ,} }
        ))->code;
*variable_rule = Pugs::Compiler::Regex->compile(q(
                <variable> | <positional_variable>
                        
                { return { variable => $() ,} }
        ))->code;
*match_variable = Pugs::Compiler::Regex->compile(q(
                <num_variable>    
                        
                { return { match_variable => $_[0]{num_variable}() ,} }
        ))->code;
*named_capture_body = Pugs::Compiler::Regex->compile(q(
                    [ \\( <rule> \\) { return { rule => $_[0]{rule}(), } } ]
                | [ \\[ <rule> \\] { return { rule => $_[0]{rule}(), } } ]
                | [ <metasyntax> { return { rule => $_[0]{metasyntax}(), } } ]
        ))->code;
*named_capture = Pugs::Compiler::Regex->compile(q(
                \\$ \\< <ident> \\> <?ws>? \\:\\= <?ws>? <named_capture_body>
                
                { my $body = $_[0]{named_capture_body}();
                    $body->{ident} = $_[0]{ident}();
                    return { named_capture => $body, } 
                }
        ))->code;
*before = Pugs::Compiler::Regex->compile(q(
                \\< before <?ws> <rule> \\> 
                
                { return { before => {
                                rule  => $_[0]{rule}(),
                        }, } 
                }
        ))->code;
*after = Pugs::Compiler::Regex->compile(q(
                \\< after <?ws> <rule> \\> 
                
                { return { after => {
                                rule  => $_[0]{rule}(),
                        }, } 
                }
        ))->code;
*capturing_group = Pugs::Compiler::Regex->compile(q(
                \\( <rule> \\)
                        
                { return { capturing_group => $_[0]{rule}() ,} }
        ))->code;
*colon = Pugs::Compiler::Regex->compile(q(
                ( 
                        [ \\:\\:\\: ] | 
                        [ \\:\\? ]   | 
                        [ \\:\\+ ]   | 
                        [ \\:\\: ]   | \\: |
                        [ \\$\\$ ]   | \\$ |
                        [ \\^\\^ ]   | \\^
                )
                        
                { return { colon => $_[0]->() ,} }
        ))->code;
*quantifier = Pugs::Compiler::Regex->compile(q(
        $<ws1>   := (<?ws>?)
        $<term>  := (<@Pugs::Grammar::P6Rule::rule_terms>)
        $<ws2>   := (<?ws>?)
        $<quant> := (
                [ 
                        [ \\?\\? ] |
                        [ \\*\\? ] |
                        [ \\+\\? ] |
                        \\?       |
                        \\*       |
                        \\+
                ]?
        )
        $<ws3>   := (<?ws>?)
        
        { return {  
                        term  => $_[0]{term}(),
                        quant => $_[0]{quant}(),
                        ws1   => $_[0]{ws1}(),
                        ws2   => $_[0]{ws2}(),
                        ws3   => $_[0]{ws3}(),
                } 
        }
))->code;
*concat = Pugs::Compiler::Regex->compile(q(
        $<q1> := (<quantifier>) 
        [
                $<q2> := (<concat>) 
                
                { return { concat => [ 
                                { quant => $_[0]{q1}() ,}, 
                                $_[0]{q2}(),
                        ] ,} 
                } 
        |    
                { return { quant => $_[0]{q1}() ,} } 
        ]
))->code;
*rule = Pugs::Compiler::Regex->compile(q(
        $<q1> := (<concat>) 
        [
                $<q2> := (<rule>) 

                { return { alt => [ 
                                $_[0]{q1}(), 
                                $_[0]{q2}(),
                        ] ,} 
                }
        |           
                { return $_[0]{q1}() } 
        ]
))->code;

unshift @rule_terms, 'dot';
unshift @rule_terms, 'plain_text';
unshift @rule_terms, 'special_char';
push @rule_terms, 'non_capturing_group';
unshift @rule_terms, 'closure_rule';
unshift @rule_terms, 'variable_rule';
unshift @rule_terms, 'match_variable';
unshift @rule_terms, 'named_capture';
unshift @rule_terms, 'before';
unshift @rule_terms, 'after';
unshift @rule_terms, 'capturing_group';
push @rule_terms, 'colon';

    # XXX - currying should be made automatically by <@xxx> runtime
    # curry @rule_terms with Grammar
    @rule_terms = map { 
        my $method = $_;
        sub{ 
            # warn "Trying $method\n";
            my $match = Pugs::Grammar::Rule->$method(@_);
            #warn "Match $method ".Dumper($match) if $match->{bool};
            return $match;
        }
    }
    @rule_terms;

1;