#!/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}]";
}