root/src/perl6/viv

#!/usr/local/bin/perl

# The start of a gimme5 replacement based on STD parsing.
#
use strict;
use warnings;

use STD;
use utf8;
use YAML::XS;
use feature 'say';

$::ACTIONS = 'Actions';
my $OPT_pos = 0;
my $OPT_match = 0;
my $OPT_log = 0;
my @did_ws;

sub USAGE {
    print <<'END';
viv [switches] filename
    where switches can be:
        --ast   spit out an abstract syntax tree (default)
        --p5    spit out a Perl 5 representation (unimpl)
        --p6    spit out a Perl 6 representation (partially impl)
        --pos   include position info in AST
        --match include match tree info in AST
        --log   emit debugging info to standard error
END
    exit;
}


sub MAIN {
    my $output = 'ast';

    USAGE() unless @_;
    while (@_) {
        last unless $_[0] =~ /^--/;
        my $switch = shift @_;
        if ($switch eq '--ast') {
            $output = 'ast';
        }
        elsif ($switch eq '--p5') {
            $output = 'p5';
        }
        elsif ($switch eq '--p6') {
            $output = 'p6';
            $OPT_pos = 1;
        }
        elsif ($switch eq '--log') {
            $OPT_log = 1;
        }
        elsif ($switch eq '--pos') {
            $OPT_pos = 1;       # attach position and prior ws len
        }
        elsif ($switch eq '--match') {
            $OPT_match = 1;     # attach match object
        }
        elsif ($switch eq '--help') {
            USAGE();
        }
    }
#    USAGE() unless -r $_[0];
    my $r;
    if (@_ and -f $_[0]) {
        $r = STD->parsefile($_[0])->item;
    }
    else {
        my $prog;
        {
            local $/;
            $prog = <>;
        }
        $r = STD->parse($prog)->item;
    }
    if ($output eq 'ast') {
        print Dump($r);
    }
    elsif ($output eq 'p6') {
        print $r->emit_p6;
    }
    elsif ($output eq 'p5') {
        print $r->emit_p5;
    }
    else {
        die "Unknown output mode";
    }
}

###################################################################

{ package Actions;

    # Generic ast translation done via autoload

    our $AUTOLOAD;
    my $SEQ = 1;

    sub AUTOLOAD {
        my $self = shift;
        my $match = shift;
        my $r = hoist($match);
        (my $class = $AUTOLOAD) =~ s/^Actions/VAST/;
        gen_class($class);
        bless $r, $class unless ref($r) =~ /^VAST/;
        $r->{MATCH} = $match if $OPT_match;
        $match->{''} = $r;
    }

    # propagate ->{''} nodes upward
    # (untransformed STD nodes in output indicate bugs)

    sub hoist {
        my $node = shift;
        my $text = $node->text;
        my %r;
        for my $k (keys %$node) {
            my $v = $node->{$k};
            if ($k eq 'O') {
                for my $key (keys %$v) {
                    $r{$key} = $$v{$key};
                }
            }
            elsif ($k eq 'SIGIL') {
                $r{SIGIL} = $v;
            }
            elsif ($k eq '_arity') {
                $r{ARITY} = $v;
            }
            elsif ($k eq '_from') {
                $r{POS} = $v if $OPT_pos;
                if (exists $::MEMOS[$v]{'ws'}) {
                    my $wsstart = $::MEMOS[$v]{'ws'};
                    $r{WS} = $v - $wsstart if defined $wsstart and $wsstart < $v
                }
            }
            elsif ($k =~ /^[a-zA-Z]/) {
                if (ref $v eq 'ARRAY') {
                    my $zyg = [];
                    for my $z (@$v) {
                        if (ref $z) {
                            if (ref $z eq 'ARRAY') {
                                push @$zyg, $z;
                            }
                            elsif (exists $z->{''}) {
                                push @$zyg, $z->{''};
                            }
                        }
                        else {
                            push @$zyg, $z;
                        }
                    }
                    $r{$k} = $zyg;
                    $r{zygs}{$k} = $SEQ++ if @$zyg and $k ne 'sym';
                }
                elsif (ref $v) {
                    if (exists $v->{''}) {
                        $r{$k} = $v->{''};
                    }
                    else {
                        $r{$k} = $v;
                    }
                    $r{zygs}{$k} = $SEQ++;
                    unless (ref($r{$k}) =~ /^VAST/) {
                        my $class = "VAST::$k";
                        gen_class($class);
                        bless $r{$k}, $class;
                    }
                }
                else {
                    $r{$k} = $v;
                }
            }
        }
        $r{TEXT} = $text unless exists $r{zygs};
        \%r;
    }

    sub EXPR {
        my $self = shift;
        my $match = shift;
        my $r = hoist($match);
        (my $class = $r->{kind} // ref $r) =~ s/^STD/VAST/;
        gen_class($class);
        $match->{''} = bless $r, $class;
    }

    sub gen_class {
        my $class = shift;
        no strict 'refs';
        return if @{$class . '::ISA'};
        warn "Creating class $class\n" if $OPT_log;
        @{$class . '::ISA'} = 'VAST::Base';
    }

}

###################################################################

{ package VAST::Base;
    sub emit_p5 { die "Perl 5 emitter unimplemented" }

    sub emit_p6 { my $self = shift;
        my $text = $self->get_ws;
        my @sym;
        if (exists $self->{sym}) {
            my $sym = $self->{sym};
            if (ref $sym eq 'ARRAY') {
                @sym = @$sym;
            }
            else {
                @sym = $sym;
            }
        }
        if ($self->{zygs}) {
            my @zyg = $self->get_zygs;
            my $arity = $self->{ARITY} // '';
            my $sym = $self->{sym} // '';
            if ($arity eq 'BINARY') {
                $text .= $zyg[0] . $zyg[2] . $zyg[1];
            }
            elsif ($arity eq 'UNARY') {
                if ($self->{arg}{_from} > $self->{_from}) {
                    $text .= $zyg[0] . $zyg[1];
                }
                else {
                    $text .= $zyg[1] . $zyg[0];
                }
            }
            elsif ($sym eq 'identifier') {
                $text .= join('', reverse @zyg);
            }
            else {
                $text .= join('', @zyg);
            }
        }
        elsif (exists $self->{TEXT}) {
            $text .= $self->{TEXT};
        }
        elsif (@sym) {
            $text .= join('', @sym);
        }
        $self->ret($text);
    }

    sub ret { my $self = shift;
        warn ref $self, " returns ", $_[0], "\n" if $OPT_log;
        $_[0];
    }

    sub get_zygs { my $self = shift;
        my @zygs;
        if ($self->{zygs}) {
            my $zygs = $self->{zygs};
            for my $key (sort {$zygs->{$a} <=> $zygs->{$b}} keys %$zygs) {
                push @zygs, $self->get_zyg($key);
            }
        }
        @zygs;
    }

    sub get_zyg { my $self = shift;
        my $key = shift;
        my $part = $self->{$key};
        my @zygs;
        if (ref $part eq 'ARRAY') {
            my @kids = @$part;
            for my $kid (@kids) {
                if (ref $kid) {
                    push @zygs, $kid->emit_p6 // '';
                }
                else {
                    push @zygs, $kid;
                }
            }
        }
        elsif (ref $part) {
            push @zygs, $part->emit_p6 // '';
        }
        else {
            push @zygs, $key . '=' . $part;
        }
        @zygs;
    }

    sub get_ws { my $self = shift;
        my $ws = $self->{WS} // 0;
        my $pos = $self->{POS};
        if ($ws and not $did_ws[$pos]++) {
            substr($::ORIG, $pos - $ws, $ws)
        }
        else {
            '';
        }
    }
        
}

{ package VAST::sample; our @ISA = 'VAST::Base';
    sub emit_p6 { my $self = shift;
    }
}

{ package VAST::PreSym; our @ISA = 'VAST::Base';
    sub emit_p6 { my $self = shift;
        my $text = $self->get_ws;
        $text .= $self->{sym};
        $text .= $self->SUPER::emit_p6(@_);
        $text;
    }
}

{ package VAST::CircumSym; our @ISA = 'VAST::Base';
    sub emit_p6 { my $self = shift;
        my $text = $self->get_ws;
        $text .= $self->{sym}[0];
        $text .= $self->SUPER::emit_p6(@_);
        $text .= $self->{sym}[1];
        $text;
    }
}

{ package VAST::FirstLast; our @ISA = 'VAST::Base';
    sub emit_p6 { my $self = shift;
        my $text = $self->get_ws;
        $text .= $self->{FIRST};
        $text .= $self->SUPER::emit_p6(@_);
        $text .= $self->{LAST};
        $text;
    }
}

{ package VAST::comp_unit; our @ISA = 'VAST::Base';
    sub emit_p6 { my $self = shift;
        my $text = $self->SUPER::emit_p6(@_);
        if (not @did_ws[@::MEMOS-1]) {
            my $finalws = $::MEMOS[-1]{ws};
            $text .= substr($::ORIG, $finalws, -1) if $finalws;
        }
        $self->ret($text);
    }
}

{ package VAST::Comma; our @ISA = 'VAST::Base';
    sub emit_p6 { my $self = shift;
        my $text = $self->get_ws;
        
        my @list = $self->get_zyg('list');
        my @delims = $self->get_zyg('delims');
        while (@list) {
            $text .= shift(@list) . (shift(@delims)//'');
        }
        $self->ret($text);
    }
}

{ package VAST::statementlist; our @ISA = 'VAST::Base';
    sub emit_p6 { my $self = shift;
        my $text = $self->get_ws;
        
        my @statement = $self->get_zyg('statement');
        my @terminator = $self->get_zyg('eat_terminator');
        while (@statement or @terminator) {
            $text .= shift(@statement) . (shift(@terminator)//'');
        }
        $self->ret($text);
    }
}

{ package VAST::nibbler; our @ISA = 'VAST::Base';
    sub emit_p6 { my $self = shift;
        my $text = '';
        my @nibbles = $self->get_zyg('nibbles');
        for my $nibble (@nibbles) {
            if (ref $nibble) {
                $text .= $nibble->emit_p6;
            }
            else {
                $text .= $nibble;
            }
        }
        $self->ret($text);
    }
}

{ package VAST::quibble; our @ISA = 'VAST::Base';
    sub emit_p6 { my $self = shift;
        my $text = $self->get_ws;
        
        my @babble = @{$self->{babble}{B}};
        my @nibble = $self->get_zyg('nibble');
        $text .= $babble[0] . $nibble[0] . $babble[1];
        $self->ret($text);
    }
}

{ package VAST::quote; our @ISA = 'VAST::Base';
    sub emit_p6 { my $self = shift;
        my $text = $self->get_ws;
        
        if ($self->{nibble}) {
            my @nibble = $self->get_zyg('nibble');
            $text .= $self->{sym}[0] . $nibble[0] . $self->{sym}[1];
        }
        else {  
            my @quibble = $self->get_zyg('quibble');
            $text .= $self->{sym} . $quibble[0];
        }
        $self->ret($text);
    }
}

{ package VAST::variable_declarator; our @ISA = 'VAST::Base';
    sub emit_p6 { my $self = shift;
        my $text = $self->get_ws;
        $text .= ($self->get_zyg('variable'))[0];
        $text .= join '', $self->get_zyg('shape');
        $text .= join '', $self->get_zyg('trait');
        $text .= join '', $self->get_zyg('post_constraint');
        $text;
    }
}

{ package VAST::scope_declarator; our @ISA = 'VAST::PreSym'; }
{ package VAST::statement_control; our @ISA = 'VAST::PreSym'; }
{ package VAST::statement_prefix; our @ISA = 'VAST::PreSym'; }
{ package VAST::version; our @ISA = 'VAST::PreSym'; }

{ package VAST::block; our @ISA = 'VAST::CircumSym'; }
{ package VAST::circumfix; our @ISA = 'VAST::CircumSym'; }
{ package VAST::postcircumfix; our @ISA = 'VAST::CircumSym'; }
{ package VAST::args; our @ISA = 'VAST::FirstLast'; }

if ($0 eq __FILE__) {
    ::MAIN(@ARGV);
}

# vim: ts=8 sw=4 noexpandtab smarttab