#!/usr/bin/perl

use Parse::RecDescent;
use Data::Dumper;
use strict;

use constant GRAMMAR => q{
	kwid		: block(s) <commit> /^\Z/
				{ $return = $item[1] }
			| <error: Kwid parsing failed>
	block		: begin_tag <commit> block(s) end_tag
				{ $return=[ 'tag' => [ $item[1], $item[3] ] ] }
			| <error?: Begin tag not matched> <reject>
			| /(\*)+/ <commit> list_data "\n"
				{ $return=[ 'list' => [ $item[1], $item[3] ] ] }
			| <error?: List item malformed> <reject>
			| /(=+)[ \t]+(.*)/ 
				{ $return=[ 'head' => [$1, $2] ] }
				"\n"
			| /[ \t]+(.*)\n/
				{ $return=[ 'lit' => $item[1] ] }
			| /\n+/
				{ $return=[ 'endp' ] }
			| text_line
	list_data	: /=|1|/ /[ \t]+/ text_block
				{ $return=[$item[1] => $item[3]] }
			| { $return = [] }
	text_line	: text_block "\n"
				{ $return = [ 'text' => $item[1] ] }
	text_block	: text_chunk(s)
				{ $return = main::reduce($item[1]) }
	text_chunk	: /[BCEILX]/ {extract_bracketed($text,'[')}
				{ $return = [ $item[1] => main::unb($item[2]) ] }
			| /[BCEILX]/ {extract_bracketed($text,'\{')}
				{ $return = [ $item[1] => main::unb($item[2]) ] }
			| {extract_bracketed($text,'[')}
				{ $return = [ '[' => main::unb($item[1]) ] }
			| /[BCEILX]|[^=BCEILX\[\n][^=BCEILX\[\n]*/
				{ $return = $item[1] }
			|
	begin_tag	: /=begin[ \t]+([\w\-]+)[ \t]*\n/
				{ $return = $1 }
	end_tag		: /=end[ \t]+([\w\-]+)[ \t]*\n/
				{ $return = $1 }
};		  

$::RD_ERRORS = 1;
$::RD_WARN = 1;
$::RD_HINT = 1;
$::RD_TRACE = undef;
$|=1;
$Parse::RecDescent::skip = '';
my $parser = new Parse::RecDescent (GRAMMAR) or
	    die("Internal error: failed loading Kwid grammar");
my $kwid = $parser->kwid(join '', <>);
die("Parsing failed") unless defined $kwid;
print Data::Dumper::Dumper($kwid);
exit 0;

sub reduce {
    my $list = shift;
    my $last = undef;
    my @newlist;
    # Ok, it's late and I'm not getting this. Someone tell me where
    # the production name is getting snuck in, and I'll fix it. -AJS
    pop @$list if $list->[-1] eq 'text_chunk';
    foreach my $item (@$list) {
	if (!ref($item) && defined($last)) {
	    $newlist[-1] .= $item;
	} else {
	    my $newitem = $item;
	    $last = (ref($newitem) ? undef : \$newitem);
	    push @newlist, $newitem;
	}
    }
    return [@newlist];
}

sub unb {
    my $text = shift;
    $text =~ s/^[\[\{](.*)[\]\}]$/$1/;
    return $text;
}