#!/usr/bin/perl

# This program attempts to translate some of the constructs pugs does not
# yet handle into constructs that it does handle.

use strict;
use warnings;

my %text;
my $curclass;
my %proto;
my %protosig;
my %multis;

while (<>) {
    if (/role (\w+)\[\*?(.*?)\]/) {
	my $name = $1;
	my $param = $2;
	$text{$name} = "#line " . ($. + 2) . "\n";
	while (<>) {
	    s/\Q$param\E/\$?PARAM/g;
	    last if /^\}/;
	    s/method &\./method coerce/;
	    $text{$name} .= $_;
	}
	$_ = "#line " . ($. + 1) . "\n";
	next;
    }

    if (/^class (\w+)/) {
	$curclass = $1;
    }

    s/does (\w+)\[(.*?)\] *\{/"{\n" . instantiate($1,$2) . "#line $.\n"/e and next;

    s/\( *-->/\( *%_ -->/;
    s/'([{}])'/'\\$1'/g;
    s/\$\.(expect\w+)\((.*?)\)/m:p\/<$1($2)> { return \$<$1> }\//;
    s/COMPILING::<(\W+)(\w+)>/$1COMPILING::$2/g;
    s/\(:(\w+)\((.*?)\)\)/(:$2)/;
    s/is context<rw>/is context is rw/g;
    s/^grammar Perl:ver<(.*?)>:auth<(.*)>;/grammar Perl;/;

    if (/^proto \s+ (regex|rule|token) \s+
	(\w+) \s*
	(?:\(([^)]*)\))?/x) {
	my $name = $2;
	$proto{$name}++;
	$protosig{$name} = $3;
    }
    elsif (s/^(?:multi\s+)?
	(regex|rule|token) \s+
	(\w+) ( :\w+ ( <.*?>
	            | «.*?»
		    | \{.*?\}
		    | \[.*?\]
		    )?
	      ) \s*
	(?:\(([^)]*)\))?//x) {
	my $type = $1;
	my $name = $2;
	my $adv = $3;
	my $sig = $5;

	my $newdflt = $adv;
	$newdflt =~ s/:(\w+)$/'$1'/ or
	$newdflt =~ s/:sym(<.*?>)/$1/ or
	$newdflt =~ s/:sym(«.*?»)/$1/ or
	$newdflt =~ s/:sym(\(.*?\))/$1/ or
	$newdflt =~ s/:sym(\[.*?\])/$1/;

	my $newparm = ":\$sym is context is rw = $newdflt";

	my $newsig = $protosig{$name} || "";
	if ($newsig =~ /^\s*-->/) {
	    $newsig =~ s/-->/$newparm -->/;
	}
	elsif ($newsig =~ /-->/) {
	    $newsig =~ s/-->/, $newparm -->/;
	}
	elsif ($newsig) {
	    $newsig .= ', ' . $newparm;
	}
	else {
	    $newsig = $newparm;
	}
	my $mangle = $name . $adv;
	$mangle =~ s/:(sym)?/_/;
	$mangle =~ s/(\W)/sprintf("_%02x_",ord($1))/eg;
	$mangle =~ s/__/_/g;
	$mangle =~ s/_$//;
	push(@{$multis{$name}}, $mangle);
	substr($_,0,0,"$type $mangle ($newsig)")
    }
}
continue {
    print $_;
}

foreach my $name (sort keys %multis) {
    print "token $name {\n";
    for (@{$multis{$name}}) {
	print "    | <$_>\n";
    }
    print "}\n\n";
}

sub instantiate {
    my ($name, $arg) = @_;
    my $text = $text{$name} or die "Can't find role $name\n";
    $text =~ s/\$\?PARAM/%($arg)/g;
    $text =~ s/::\?CLASS/$curclass/g;
    $text;
}