The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use v5.10;
use MooseX::Declare;
use Regexp::Grammars;
use Mildew::AST;
class Mildew::Frontend::M0ld {
    # $REGS needs to be a global variable for local to work
    our $REGS = [];

    # converts an arrayref of statements to a Mildew::AST::Block
    sub stmts_to_block {
        my ($stmts) = @_;
        my @stmts;

        my %seqs;
        for my $stmt_label (@{$stmts}) {
            for my $label (@{$stmt_label->[0]}) {
                if ($seqs{$label}) {
                    die "Duplicate label $label.\n";
                }
                $seqs{$label} = Mildew::AST::Seq->new(stmts=>[],id=>$label);
            }
        }
        my @seqs = ();
        for my $stmt_label (@{$stmts}) {
            my $labels = $stmt_label->[0];
            for my $label (@{$stmt_label->[0]}) {
                push(@seqs,$seqs{$label});
            }
            my $stmt = $stmt_label->[1];
            unless (@seqs) {
                push(@seqs,Mildew::AST::Seq->new(stmts=>[])) if $stmt;
            }
            if (!defined $stmt) {
            } elsif ($stmt->{goto}) {
                push(@{$seqs[-1]->stmts},Mildew::AST::Goto->new(block=>$seqs{$stmt->{goto}}));
            } elsif ($stmt->{cond}) {
                push(@{$seqs[-1]->stmts},Mildew::AST::Branch->new(
                    cond=>$stmt->{cond},
                    then=>$seqs{$stmt->{then}},
                    else=>$seqs{$stmt->{else}}
                ));
            } elsif ($stmt) {
                use Data::Dumper;
                push(@{$seqs[-1]->stmts},$stmt);
            }
        }
        Mildew::AST::Block::Simplified->new(stmts=>\@seqs,regs=>$REGS);
    }


    method parse($source) {
        # working around a bug in Regexp::Grammars by creating a new parser every time
    my $parser = qr/
    ^<top>$
    <rule: top>
    (?{ local $REGS=[] })
    (?: <[stmt_with_labels]> ; )*
    (?{ $MATCH = stmts_to_block($MATCH{stmt_with_labels}) })
    
    <token: stmt_with_labels>
    (<[label]> <.ws>? \: <.ws>?)* <stmt>
    (?{ $MATCH = [$MATCH{label},$MATCH{stmt}] })

    <token: ws>
    (?> (?: \s+ | \#[^\n]* )*)
    
    <token: stmt>
    (?: <MATCH=goto>|<MATCH=br>|<MATCH=assign>|<MATCH=decl>|<MATCH=noop>)
    
    <rule: decl>
    my <register>
    (?{ my $reg = substr($MATCH{register}->name,1);push(@{$REGS},$reg);$MATCH = undef })
    
    <rule: call>
    <invocant=value> \.  <identifier=value>
    \(
    (?:<[argument]> ** ,)?
    \)
    (?{ 
        $MATCH = Mildew::AST::Call->new(
            identifier=>$MATCH{identifier},
            capture=>Mildew::AST::Capture->new(
                invocant => $MATCH{invocant},
                positional => [grep { ! $_->isa('Mildew::AST::Pair') } @{$MATCH{argument}}],
                named => [map { $_->key, $_->value } grep { $_->isa('Mildew::AST::Pair') } @{$MATCH{argument}}]
            )
        )
    })
    
    <rule: assign>
    (?:my)? <register> = <rvalue>
    (?{ $MATCH = Mildew::AST::Assign->new(lvalue=>$MATCH{register},rvalue=>$MATCH{rvalue}) })
    <token: rvalue>
    <MATCH=call> | <MATCH=value>
    
    <token: goto>
    goto \s+ <label>
    (?{$MATCH = {goto=>$MATCH{label}}})
    
    <token: argument>
    (?: <MATCH=named_argument> | <MATCH=value> )
    
    <rule: named_argument>
    (?: \: <key=value> \( <val=value> \) )
    (?{$MATCH = Mildew::AST::Pair->new(key=>$MATCH{key},value=>$MATCH{val})})
    
    
    <token: noop>
    noop
    (?{$MATCH = undef})
    
    <rule: br>
    if <value> <then=branch> else <else=branch>
    (?{$MATCH = {cond=>$MATCH{value},then=>$MATCH{then},else=>$MATCH{else}}})
    
    <rule: branch>
    \{ goto <label> ;? \}
    (?{$MATCH = $MATCH{label}})
    
    <token: label>
    \w+
    
    <token: value>
    (?: <MATCH=integer>  | <MATCH=register> | <MATCH=string> | <MATCH=submold>)
    
    <token: integer>
    (\d+)
    (?{$MATCH = Mildew::AST::IntegerConstant->new(value=>$+)})
    
    <token: register>
    ((?> (?: \$ | \? | ยข) \p{IsAlpha} \w*))
    (?{$MATCH = Mildew::AST::Reg->new(name=>$+)})
    
    <token: string_part>
    (?:
    \\(.) (?{my %meta = (n=>"\n");$MATCH = ($meta{$^N} || $^N)}) |
    ([^\\"])  (?{$MATCH = $^N}) )
    <token: string>
    " (<[string_part]>*) "
    (?{$MATCH = Mildew::AST::StringConstant->new(value=>join('',@{$MATCH{string_part}}))})
    
    <rule: submold>
    (?{local $REGS = []})
    mold \{
    (?: <[stmt_with_labels]> ; )*
    \}
    (?{$MATCH = stmts_to_block($MATCH{stmt_with_labels});})
    /x;
        unless ($source =~ $parser) {
            die "Can't parse m0ld code";
        }
        $/{top};
    }
}