#!/usr/bin/perl -w
use strict;
use XML::Parser;
#use Term::ANSIColor qw(:constants);
BEGIN {require 'dummy_color'};
use Attribute::Handlers;
use Data::Dumper;
my $parser = new XML::Parser();
my %context = (
	choice=>0,
	cache=>'',
	lookahead=>0,
	first_choice=>0,
	brace=>'closed'
);
sub emit($) {
	if ($context{q}) {
		$context{q}{cache} .= shift;
	} else {
		print shift;
	}
	die "emit takes only one argument:@_" if @_;
}
my %atomic = ();
$parser->setHandlers(
	Char=>sub {
		my ($expat,$string) = @_;	
		return if $string =~ /^\s*$/;
		return if $context{description};
		emit quotemeta($string);
	},
	Start=>sub {
		my ($expat,$element,%attrs) = @_;	
		$element =~ s/^g://;
		my $sub = $main::{$element};
		unless (defined $sub) {
			die "no $element";
			return;
		}
		if ($context{choice}>0) {
			emit BLUE."|".RESET if (!$context{first_choice}) &&
				$atomic{$element};
			$context{first_choice} = 0 if $context{first_choice};
		}
		$context{q}{count}++ if $context{q} && $atomic{$element};
		no strict 'refs';

		&{$sub}(%attrs);
	},
	End=>sub {
		my ($expat,$element,%attrs) = @_;	
		$element =~ s/^g://;
		my $sub = $main::{$element."_"};
		unless (defined $sub) {
			die "no ${element}_";
			return;
		}

		no strict 'refs';
		&{$sub}(%attrs);
	},
	Comment=>sub {}
);
$parser->parsefile(shift);
emit "\n";

sub Closed :ATTR {
	no strict 'refs';
	my ($package,$symbol) = @_;
	my $name = *{$symbol}{NAME} . "_";
	*{$name} = sub {};
}
sub Atom :ATTR {
	no strict 'refs';
	my ($package,$symbol) = @_;
	my $name = *{$symbol}{NAME};
	$atomic{$name} = 1;
}

sub token {
	my %attr = @_;
	emit "rule $attr{name} {";
	emit "<$attr{'alias-for'}>" if $attr{'alias-for'};
}
sub token_  {
	my %attr = @_;
	emit "}\n"
}
sub production {
	my %attr = @_;
	emit "rule $attr{name} {"
}
sub production_  {
	my %attr = @_;
	emit "}\n"
}
sub ignore {
	warn "ignoring: @_\n";
	for (@_) {
		$main::{$_} = sub {};
		$main::{$_ . "_"} = sub {};
	}
}


## Atoms
sub ref :Closed :Atom {
	my %attr = @_;
	emit "<$attr{name}>";
} 
sub string :Atom {
}
sub string_ {
}

### control flow
sub choice {
	$context{choice}++;
	$context{first_choice} = 1;
}
sub choice_ {
	$context{choice}--;
}
sub sequence :Atom {
	emit GREEN."[".RESET;
	$context{choice}--;
}
sub sequence_  {
	emit GREEN."]".RESET;
	$context{choice}++;
}
#XXX: quantifiets should use lookahead to determine if square brackets 
#XXX: are nessary
sub quantifier :Atom {
	my %tmp = @_;
	while (my ($name,$symbol) = each %tmp) {
		$main::{$name} = sub {
			my $prev = $context{q};
			$context{q} = {};
			$context{q}{symbol} = $symbol;
			$context{q}{prev} = $prev;
			$context{q}{count} = 0;
		};
		$main::{$name."_"} = sub {
			my $q = $context{q};
			#print BLUE,"q:".Dumper($context{q}),"\n",RESET;
			$context{q} = $context{q}{prev};
			emit "[" if $context{q};
			emit "[" if $q->{count} > 1;
			emit $q->{cache};
			emit "]" if $q->{count} > 1;
			emit $symbol;
			emit "]" if $context{q};
		};
	}
}
INIT { quantifier(qw(
zeroOrMore *
oneOrMore  +
optional   ?
))} 

sub optionalSkip :Atom :Closed {emit " <S>* "}
sub requiredSkip :Atom :Closed {emit " <S>+ "}

sub close_brace {
	emit "]+[" if $context{brace} eq 'open';
	emit "+" if $context{brace} eq 'closed';
}
sub sign() {
	return "-" if $context{complement};
	return "+";
}
sub char {
	#print BLUE,"context:$context{brace}\n",RESET;
	return unless $context{charClass};
	emit sign if $context{brace} eq 'closed';
	emit "[" unless $context{brace} eq 'open';
	$context{brace}='open';
}
sub char_ {
}
sub charCode :Closed {
	my %attr = @_;
	emit sign if $context{brace} eq 'closed';
	emit "[" unless $context{brace} eq 'open';
	$context{brace}='open';
	print "\\x[$attr{value}]";
}
sub charRange :Closed {
	my %attr = @_;
	close_brace();
	emit "[$attr{minChar}..$attr{maxChar}]";
	$context{brace}='closed';
}
sub charCodeRange :Closed {
	my %attr = @_;
	close_brace();
	emit "[\\x[$attr{minValue}]..\\x[$attr{maxValue}]]";
	$context{brace}='closed';
}
sub charClass :Atom {
	$context{brace}='none';
	$context{charClass}++;
	emit "<";
	emit "-" if $context{complement};
}
sub charClass_ {
	$context{charClass}--;
	emit "]" if $context{brace} eq 'open';
	$context{brace}='none';
	emit ">";
}
sub complement {
	$context{complement} = 1;
}
sub complement_ {
	$context{complement} = 0;
}

# XXX skip
INIT { ignore qw(skip) }
# XXX character classes

## things I don't understand and/or don't know how to translate 
sub description {
	$context{description}++;
}
sub description_ {
	$context{description}--;
}


INIT { ignore qw(exposition-production primary transition-default state start language grammar tref transition state-list ) }

# XXX OpTable

INIT {ignore qw(binary exprProduction prefix postfix level)}

=for later
}

### charackter classes
sub close_bracket {
	warn "\t\tclosing bracket:$_[0]";
	emit "]" if $context{open_bracket};
}
sub open_bracket {
	emit "[" unless $context{open_bracket};
	$context{open_bracket}++;
}
sub charRange {
	my ($expat,$name,%attr) = @_;
	close_bracket();
	emit "[$attr{minChar}..$attr{maxChar}]";
}