#!/usr/bin/perl

use strict;
use XML::LibXML;
use XML::LibXML::XPathContext;
use Data::Dumper;
use File::Slurp;
use File::Temp 'tempdir';

use constant SVGA_NS => 'http://www.w3.org/2005/02/svg-annotations';

my %type2name = (
                Boolean             => 'boolean',
                ContentType         => 'content-type',
                Focus               => 'focus',
                FontFamilyValue     => 'font-family-value',
                FontSizeValue       => 'font-size-value',
                FormatList          => 'list-of-content-types',
                LanguageID          => 'language-id',
                Coordinates         => 'list-of-coordinates',
                LanguageIDs         => 'list-of-language-ids',
                Numbers             => 'list-of-numbers',
                ListOfIRI           => 'list-of-IRIs',
                FontList            => 'list-of-family-names',
                Color               => 'color',
                SVGColor            => 'color',
                Paint               => 'paint',
                PathData            => 'path-data',
                Points              => 'points-data',
                TransformList       => 'transform',
                Coordinate          => 'coordinate',
                Length              => 'length',
                Lengths             => 'list-of-lengths',
                Number              => 'number',
                IRI                 => 'IRI',
                'QName'             => 'QName',
                String              => 'string',
                ListOfString       => 'list-of-strings'
                );

### @@ TODO
#
# - make IDs work
# - check all links, esp. datatypes.html

# CLM (2008-07-10):
#   Get configuration from the command line.

die "Syntax: makeTables.pl RNGDIR RNGDRIVER TYPELINKS PROPTXT ELTTXT ATTRTPL ELTTPL ATTROUT ELTOUT" unless @ARGV == 9;
my ($RNG, $RNGDRIVER, $TYPELINKS, $PROP_DB, $ELEM_DB, $ATTRTPL, $ELTTPL, $ATTROUT, $ELTOUT) = @ARGV;
my $OUT = tempdir(CLEANUP => 1);

# configuration
#my $RNG = '../relaxng/Tiny-1.2-NG';
#my $OUT = '../relaxng/tables-Tiny-1.2-NG';
#my $SPEC = '../spec/mobile/1.2/1.2NG/master/';
#my $PROP_DB = $SPEC . 'properties.txt';
#my $ELEM_DB = $SPEC . 'elements.txt';
#my $TPL = './makeTables.templates/';
# /configuration

# let's rock
my %propLinks = getLinks($PROP_DB);
my %elemLinks = getLinks($ELEM_DB);
my $xc = init("$RNG/$RNGDRIVER");
my %media = getMedia($xc);
my %props = getProperties($xc);
my %attrs = getAttributes($xc);
my %elems = getElements($xc);

my $pStr = generatePropertiesHTML(%props);
write_file("$OUT/properties.html", $pStr);
my $aStr = generateAttributesHTML(%attrs);
write_file("$OUT/attributes.html", $aStr);
my $eStr = generateElementsHTML(%elems);
write_file("$OUT/elements.html", $eStr);

runTemplate($ELTTPL, $ELTOUT, $OUT);
runTemplate($ATTRTPL, $ATTROUT, $OUT);

# --- inits the tree with the schema driver and returns an XPath Context
sub init {
    my $xml = XML::LibXML->new;
    my $ygg = $xml->parse_file(shift);

    my $xc = XML::LibXML::XPathContext->new($ygg);
    $xc->registerNs('rng', 'http://relaxng.org/ns/structure/1.0');
    $xc->registerNs('rnga', 'http://relaxng.org/ns/compatibility/annotations/1.0');
    $xc->registerNs('svga', SVGA_NS);

    # --- replace each include to make a single tree
    for my $inc ($xc->findnodes('//rng:include')) {
        my $href = $inc->getAttributeNS(undef, 'href');
        my $sub = $xml->parse_file("$RNG/$href")->documentElement;
        $sub->setAttributeNS('http://dahut.org/the.dahuts.will.rock.you/', 'darobin:file', $href);
        $ygg->adoptNode($sub);
        $inc->parentNode->replaceChild($sub, $inc);
    }

    return $xc;
}

# --- get all properties for an XPath Context
sub getProperties {
    my $xc = shift;
    my %props;
	# special case opacity
	$props{opacity} = {
		animatable	=> 'true',
		inheritable	=> 'false',
		content		=> { type => 'choice', value => [ 'inherit', { ref => 'Number' } ] },
#		media		=> 0,
	};

    for my $prop ($xc->findnodes('//rng:define[@name="svg.Properties.attr" and @combine="interleave"]')) {
        # resolve references
        if (my @ref = $xc->findnodes('./rng:ref', $prop)) {
            for my $r (@ref) {
                my $to = $r->getAttributeNS(undef, 'name');
                my $df = $xc->getContextNode->createDocumentFragment;
                $df->appendChild($_) for $xc->findnodes("//rng:define[\@name='$to' and \@combine='interleave']/node()");
                $r->parentNode->replaceChild($df, $r);
            }
        }

        # now process all uniformly
        for my $attr ($xc->findnodes('.//rng:attribute', $prop)) {
            my $name = $attr->getAttributeNS(undef, 'name');
            warn "Found a duplicate property declaration for '$name', skipping.\n" and next if exists $props{$name};
            $props{$name} = {
                            animatable   => $attr->getAttributeNS(SVGA_NS, 'animatable'),
                            inheritable  => $attr->getAttributeNS(SVGA_NS, 'inheritable'),
                            content      => findAttributeValue($attr),
#							media		 => $media{$name} || 0,
                            };
            if ($props{$name}{content}{type} eq 'choice' and not grep { $_ eq 'inherit' } @{$props{$name}{content}{value}}) {
                warn "Property '$name' does not have inherit in its value list.\n";
                #push @{$props{$name}{content}{value}}, 'inherit';
            }
            # CLM: don't warn about non-animatable properties, since we do have some of these now
            # warn "Dubious: non-animatable property '$name' found.\n" unless $props{$name}{animatable} eq 'true';
        }
    }
    #print Dumper(\%props);
    return %props;
}


# --- get all attributes that aren't properties for an XPath Context
# note that in Tiny, opacity is a special case that works like an attribute
sub getAttributes {
    my $xc = shift;
    my %attrs;
    for my $attr ($xc->findnodes('//rng:attribute[not(ancestor::rng:define[@name="svg.Properties.attr"])]')) {
        my $name = $attr->getAttributeNS(undef, 'name');
        next if $name eq 'opacity';

        # other occurences of the same attribute
        my $i = 0;
        my $realName = $name;
        # CLM: special case 'id' here so that only one entry of it exists
        while ($realName ne 'id' && exists $attrs{$realName}) {
            $i++;
            $realName = "${name}_$i";
        }

        $attrs{$realName} = {
                        animatable   => $attr->getAttributeNS(SVGA_NS, 'animatable'),
                        inheritable  => $attr->getAttributeNS(SVGA_NS, 'inheritable'),
                        content      => findAttributeValue($attr),
                        parents      => distinct(findElementParents($attr)),
                        };
        warn "Dubious: inheritable attribute '$name' found.\n" unless $attrs{$name}{inheritable} eq 'false';

    }
    #print Dumper(\%attrs);
    return %attrs;
}


# --- get all elements for an XPath Context
sub getElements {
    my $xc = shift;
    my %elems;
    for my $elem ($xc->findnodes('//rng:element')) {
        my $name = $elem->getAttributeNS(undef, 'name');

        $elems{$name} = findAttributes($elem);
        if ($name eq 'a') {
            my $link = $elemLinks{$name};
            $elems{a}{elements} = "The <a href=\"$link\"><span class=\"element-name\">'$name'</span></a> element may contain any element that its parent may contain, except itself.";
        }
        elsif  ($name eq 'switch' or $name eq 'tspan') {
            my $link = $elemLinks{$name};
            $elems{$name}{elements} = "The <a href=\"$link\"><span class=\"element-name\">'$name'</span></a> element may contain any element that its parent may contain.";
        }
        else {
            $elems{$name}{elements} = findElements($elem);
        }
    }
    #print Dumper(\%elems);
    return %elems;
}

# --- get all media properties
sub getMedia {
    my $xc = shift;
    my %media;

    for my $med ($xc->findnodes('//rng:define[@name="svg.Media.attr" and @combine="interleave"]')) {
		$media{ $_->getAttributeNS(undef, 'name') }++ for $xc->findnodes('.//rng:attribute', $med);
	}
	
	return %media;
}


# --- dump to XHTML tables, the old way so don't look too hard or you'll go blind (hey, it's Sunday afternoon...)
# HTML HELPERS
sub makeTableHead {
    my $type = shift;
    my $heads = shift;
    my $summary = shift;
    my $str = "<table class='reference-list' id='$type' summary='$summary'>\n  <thead>\n    <tr>\n";
    $str .= "      <th>$_</th>\n" for @$heads;
    $str .= "    </tr>\n  </thead>\n  <tbody>\n";
    return $str;
}

sub makeTableFoot { return "  </tbody>\n</table>"; }
sub makeTick {
	my $tick = shift;
	my ($class, $char);
	if ($tick eq 'true') {
		$class = 'true';
		$char = '&#x2714;';
	}
	elsif ($tick eq 'media') {
		$class = 'media';
		$char = 'M';
	}
	else {
		$class = 'false';
		$char = '&#x2718;';
	}
    return "      <td class='$class'>$char</td>\n";
}

# PROPERTIES
sub generatePropertiesHTML {
    my %props = @_;
    my $str = makeTableHead('properties', [qw( Property ani. inh. Value )], 'Table of all the properties available in SVG Tiny 1.2');
    for my $p (sort keys %props) {
		my $link = $propLinks{$p};
		warn "No link for property '$p'" unless $link;
        $str .= "    <tr class='property' id='property_$p'>\n      <td class='property-name' nowrap='nowrap'><a href='$link'><span class='prop-name'>'$p'</span></a></td>\n";
        $str .= makeTick($props{$p}{animatable});
        $str .= makeTick($props{$p}{inheritable});
        $str .= "      <td class='property-value'>" . makeHTMLValues($props{$p}{content}) . "      </td>";
        $str .= "    </tr>\n";
    }
    $str .= makeTableFoot();
    return $str;
}


# ATTRIBUTES
sub generateAttributesHTML {
    my %attrs = @_;
    my $str = makeTableHead('attributes', [qw( Attribute ani. inh. Value Elements )], 'Table of all the attributes available in SVG Tiny 1.2');
    my $doneID = 0;
    for my $a (sort keys %attrs) {
        my $content = $attrs{$a}{content};
        if ($a eq 'id') {
          # CLM: Special case id, since it's appearing in the table twice due to its funny definition in the schema.
          next if $doneID;
          $doneID = 1;
          $content = { type => 'choice', value => [ { ref => 'ID' }, { ref => 'NCName' } ] };
        }
        my $saneID = $a;
        $saneID =~ s/:/__/g;
        my $name = $a;
        $name =~ s/_\d+$//;
        $str .= "    <tr class='attribute' id='attribute_$saneID'>\n      <td class='attribute-name' nowrap='nowrap'>$name</td>\n";
        $str .= makeTick($attrs{$a}{animatable});
        $str .= makeTick($attrs{$a}{inheritable});
        $str .= "      <td class='attribute-value'>" . makeHTMLValues($content) . "</td>";
        $str .= "      <td class='attribute-parents'>" .
                         join(', ', map { "<a href='$ELTOUT#element_$_' class='element'>$_</a>" }  @{$attrs{$a}{parents}}) .
                  "      </td>";
        $str .= "    </tr>\n";
    }
    $str .= makeTableFoot();
    return $str;
}


# ELEMENTS
sub generateElementsHTML {
    my %elems = @_;
    my $str = makeTableHead('elements', ['Elements', 'Attributes', 'prop.', 'Possible Children'], 'Table of all the elements available in SVG Tiny 1.2');
    for my $e (sort keys %elems) {
		my $link = $elemLinks{$e};
		warn "No link for element '$e'" unless $link;
        $str .= "    <tr class='element' id='element_$e'>\n      <td nowrap='nowrap'><a href='$link'><span class='element-name'>'$e'</span></a></td>\n";
        $str .= "      <td class='element-attributes'>" .
                        join(', ', 
                                map { 
                                    my $n = $_; 
                                    s/:/__/g;
                                    $n eq 'opacity' ?
                                        "<a href='$ATTROUT#property_$_' class='attribute'>$n</a>"   :
                                        "<a href='$ATTROUT#attribute_$_' class='attribute'>$n</a>" 
                                }
                                @{$elems{$e}{attributes}}
                        ) .
                  "      </td>";
        $str .= makeTick($elems{$e}{properties});
        if ($e =~ /^( a | switch | tspan )$/x) {
            $str .= "      <td class='element-children'>" . $elems{$e}{elements} . "      </td>";
        }
        else {
            $str .= "      <td class='element-children'>" .
                             join(', ', map { $_ eq '<text>' ? "&lt;text&gt;" : "<a href='#element_$_' class='element'>$_</a>" }
                                   @{$elems{$e}{elements}}) .
                      "      </td>";
        }
        $str .= "    </tr>\n";
    }
    $str .= makeTableFoot();
    return $str;
}


### HELPERS ###

# --- find referenced elements with indirection
sub findElements {
    my $node = shift;
    my $ctx = shift || [];

    for my $ref ($xc->findnodes('.//rng:ref', $node)) {
        my $rname = $ref->getAttributeNS(undef, 'name');
        push @$ctx, $rname and next unless $rname =~ /\./;
        next unless $rname =~ /\.(CM|group|ATCM)$/;
        next if $xc->findnodes('./ancestor::rng:element[@name="switch" or @name="a"]', $ref);

        for my $def ($xc->findnodes("//rng:define[\@name='$rname' and not(rng:notAllowed)]")) {
            findElements($def, $ctx);
        }
    }
    push @$ctx, $_->getAttributeNS(undef, 'name') for $xc->findnodes('.//rng:element', $node);
    push @$ctx, '<text>' if $xc->findnodes('.//rng:text', $node);

    return distinct($ctx);
}



# --- find referenced attributes with indirection
sub findAttributes {
    my $node = shift;
    my $ctx = shift || { properties => 'false', attributes => [] };

    for my $ref ($xc->findnodes('.//rng:ref', $node)) {
        my $rname = $ref->getAttributeNS(undef, 'name');
        next unless $rname =~ /\.(AT|attr|ATCM)$/;
        if ($rname eq 'svg.Properties.attr') {
            $ctx->{properties} = 'true';
        }
        elsif ($rname eq 'svg.Media.attr') { # special-casing Media attributes
			$ctx->{properties} = 'media';
            #push @{$ctx->{attributes}}, 'audio-level';
        }
        else {
            if (my $def = $xc->findnodes("//rng:define[\@name='$rname' and not(rng:empty)]")->item(0)) {
                findAttributes($def, $ctx);
            }
            else {
                warn "No define matching ref '$rname'.\n";
            }
        }
    }
    push @{$ctx->{attributes}}, $_->getAttributeNS(undef, 'name') for $xc->findnodes('.//rng:attribute', $node);

    $ctx->{attributes} = distinct($ctx->{attributes});
    return $ctx;
}


# --- find the parent 'element's with indirection
sub findElementParents {
    my $node = shift;
    my $ctx  = shift || [];

    if (my $elem = $xc->findnodes('./ancestor::rng:element', $node)->item(0)) {
        push @$ctx, $elem->getAttributeNS(undef, 'name');
    }
    elsif (my $def = $xc->findnodes('./ancestor::rng:define', $node)->item(0)) {
        my $dn = $def->getAttributeNS(undef, 'name');
        findElementParents($_, $ctx) for $xc->findnodes("//rng:ref[\@name='$dn']");
    }
    else {
        warn "Node '" . $node->getAttributeNS(undef, 'name') . "' declared in stange location.\n";
    }

    return $ctx;
}

# --- simple distinguisher
sub distinct {
    my %tmp = map { $_ => 1 } @{shift()};
    return [sort keys %tmp];
}

# --- structure the attribute values usefully
sub findAttributeValue {
    my $attr = shift;
#    if ($xc->findnodes('.//rng:data', $attr)) {
#        warn "Attribute " . $attr->getAttributeNS(undef, 'name') . " is wrong.\n";
#        return { type => 'ref', value => 'UNKNOWN' };
#    }
    if (0) {}
    elsif ($xc->findnodes('.//rng:data[@type="string"]', $attr)) {
        return { type => 'text' };
    }
    elsif (my @vals = $xc->findnodes('./rng:choice/rng:value | ./rng:choice/rng:ref | ./rng:choice/rng:text', $attr)) {
        my @ret;
        for my $v (@vals) {
            if ($v->localName eq 'value') {
                push @ret, $v->textContent; # and NOT $v->getTrait('@text') :)
            }
            elsif ($v->localName eq 'text') {
                push @ret, "&lt;text>";
            }
            else {
                push @ret, { ref => $v->getAttributeNS(undef, 'name') };
            }
        }
        return { type => 'choice', value => \@ret };
    }
    elsif (my $ref = $xc->findnodes('./rng:ref', $attr)->item(0)) {
        return { type => 'ref', value => $ref->getAttributeNS(undef, 'name') };
    }
    elsif ($xc->findnodes('./rng:text', $attr)) {
        return { type => 'text' };
    }
    elsif (my $v = $xc->findnodes('./rng:value', $attr)->item(0)) {
        return { type => 'fixed', value => $v->textContent };
    }
    else {
        warn "Something is rotten in the RNG of Denmark for attr " . $attr->getAttributeNS(undef, 'name') .  "...\n";
    }
}

# --- turn common attribute structure into HTML
sub makeHTMLValues {
    my $cnt = shift;
    my ($t,$v) = ($cnt->{type}, $cnt->{value});
    if     ($t eq 'fixed') { return "'$v'"; }
    elsif  ($t eq 'text')  { return '&lt;text&gt;'; }
    elsif  ($t eq 'ref')   {
        $v =~ s/\.datatype//;
        return "<a href='$TYPELINKS#DataType$v'>&lt;" . getTypeName($v) . "&gt;</a>";
        #return "<span class='datatype'>&lt;$v&gt;</span>";
    }
    elsif  ($t eq 'choice')   {
        if (grep { $_ eq 'inherit' } @$v) {
          $v = [(grep { ref($_) || $_ ne 'inherit' } @$v), 'inherit'];
        }
        return join ' | ',
               map {
                   if (ref($_)) {
                       my $lnk = $_->{ref};
                       $lnk =~ s/\.datatype//;
                       "<a href='$TYPELINKS#DataType$lnk'>&lt;" . getTypeName($_->{ref}) . "&gt;</a>";
                   }
                   else {
                       "'$_'";
                   }
               }
               @$v;
    }
    else {
        warn "Unknown content type '$t' with value:\n" . Dumper($v);
        return '';
    }
}

sub getTypeName {
    my $type = shift;
    $type =~ s/\.datatype$//;
    return $type2name{$type} if exists $type2name{$type};
    return $type;
}


sub getLinks {
	my $path = shift;

	my %ret;
	open PDB, '<:utf8', $path or die "Can't open '$path': $!";
	while (my $line = <PDB>) {
		chomp $line;
		$line =~ s/^\x{feff}//; # some BOM weirdness here
		my ($k, $v) = split /\s+/, $line;
		$ret{$k} = $v;
	}
	close PDB;
	return %ret;
}


# --- Aulde Skool Templating
sub runTemplate {
    my $tplFile = shift;
    my $out = shift;
    my $inc = shift;

    my $tpl = read_file($tplFile);
    $tpl =~ s{<!--#insert ([\w+\.]+)-->}{read_file("$inc/$1")}gesm;
    $tpl =~ s{<!--#media-list -->}{makeMediaList()}gesm;
    write_file("$out", $tpl);
}

sub makeMediaList {
	my @meds = map { $_ = "<a href=\"" . $propLinks{$_} . "\"><span class=\"prop-name\">'$_'</span></a>" }
                   sort keys %media;
        my $last = pop @meds;
	return join(', ', @meds) . ", and $last";
}

