#  Copyright (c) 1997-2010
#  Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Darmstadt, Germany)
#  http://www.polymake.de
#
#  This program is free software; you can redistribute it and/or modify it
#  under the terms of the GNU General Public License as published by the
#  Free Software Foundation; either version 2, or (at your option) any
#  later version: http://www.gnu.org/licenses/gpl.txt.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#-----------------------------------------------------------------------------
#  $Project: polymake $$Id: extract_docs 9581 2010-03-16 19:33:46Z herr $
#
#  Extracting pieces of documentation into XML files
#

require Polymake::Core::InteractiveHelp;

#############################################################################################
#
#  command line options:
#
#  --outdir PATH   put the output files APPNAME.xml into the given directory;
#                  creates the directory if needed.
#
#  --wiki URL      to substitute in wiki: references
#
#  --outsuffix .SFX  generate href="APPNAME.SFX" for cross-references between applications

my $outdir=".";
my $outsuffix=".xml";
my $wikiURL;

if ( !GetOptions( 'outdir=s' => \$outdir, 'wiki=s' => \$wikiURL, 'outsuffix=s' => \$outsuffix ) or
     !@ARGV ) {
   die "usage: polymake --script extract_docs [ --outdir PATH ] APPLICATION_NAME ...\n";
}

require File::Path;
File::Path::mkpath($outdir);

#############################################################################################
#
#  XML namespace declarations

my $pmdocns="http://www.polymake.de/ns/docs#3";
my $xhtmlns="http://www.w3.org/1999/xhtml";
my $xmlid=[ "http://www.w3.org/XML/1998/namespace", "id" ];

sub doc_namespace { $pmdocns }

#############################################################################################

# InteractiveHelp => [ 'ID', Application ]
my %topic2id;

sub assign_ids {
   my $app=shift;
   my $id=0;
   my @queue=($app->help);
   while (my $help=shift @queue) {
      $topic2id{$help}=[ 'i'.$id++, $app ];
      push @queue, values %{$help->topics};
   }
}

# InteractiveHelp => WORD => [ InteractiveHelp ... ]
my %searchTree;

sub search_in_tree {
   my ($help, $word)=@_;
   my (%taboo, @ancestors);

   do {
      foreach my $topic ($help, @{$help->related}) {
	 if ($topic->name eq $word && length($topic->text)) {
	    my $me=[ $topic ];
	    $searchTree{$_}->{$word}=$me for @ancestors;
	    return $topic;
	 }
	 if (defined (my $cached=$searchTree{$topic}->{$word})) {
	    $searchTree{$_}->{$word}=$cached for @ancestors;
	    return @$cached;
	 }
	 if (my @found=uniq( map { $_->find($word) } grep { !exists $taboo{$_} } values %{$topic->topics} )) {
            @found=select_closest($help, @found) if @found>1;
	    $searchTree{$_}->{$word}=\@found for @ancestors;
	    return @found;
	 }
	 $taboo{$topic}=1;
      }
      push @ancestors, $help if $help != $_[0];
      $help=$help->parent;
   } while (defined $help);

   my $notfound=[ ];
   $searchTree{$_}->{$word}=$notfound for @ancestors;
   ()
}

sub select_closest {
   my $from=shift;
   my @closest=@_;
   my $mindist=100000000;
   foreach (@_) {
      if (defined (my $dist=$from->proximity($_))) {
         if ($dist<$mindist) {
            $dist=$mindist;
            @closest=($_);
         } elsif ($dist==$mindist) {
            push @closest, $_;
         }
      }
   }
   @closest;
}

# try to resolve cross-references of different kinds
sub search {
   my ($help, $what)=@_;

   my $app=$application;
   my @how;
   if ($what =~ /^($id_re)::/o && defined (my $other_app=lookup Core::Application($1))) {
      # [[APPNAME::something]] refers to other application
      $what=$';
      $app=$other_app;
      push @how, "!rel";
   }

   my (@topics, $obj_help);
   if ($what =~ /^ $hier_id_re $/xo and $what =~ /\./) {
      # SUBOBJECT.PROPERTY
      my @props=@{$application->object_types};
      foreach my $prop_name (split /\./, $what) {
	 @props=grep { defined } map { $_->type->lookup_property($prop_name) } @props;
      }
      @topics=uniq( grep { defined } map { $_->help_topic } @props );

   } elsif ($what =~ /^($id_re)::/o && defined ($obj_help=$app->help->find(@how, "objects", $1))) {
      # ObjectType::METHOD
      @topics=$obj_help->find($')

   } elsif ($what =~ /^($id_re (?: ::$id_re)+ )::([^:]+) $/xo && defined ($obj_help=$app->help->find(@how, "objects", $1))) {
      # Qualified::Type::METHOD
      @topics=$obj_help->find($2)

   } else {
      # single WORD
      @topics=@how ? $app->help->find(@how,$what) : search_in_tree($help, $what)
   }

   if (@topics==1) {
      my $id_app=$topic2id{$topics[0]};
      if (defined($id_app) && defined (my $app=$id_app->[1])) {
	 ($app != $application && $app->name.$outsuffix) . '#' . $id_app->[0]
      } else {
	 "#"
      }
   } elsif (@topics) {
      ("#", class => "ambiguous")

   } else {
      if ($_[1] =~ /^($qual_id_re)</o) {
         search($help, $1);
      } else {
         ("#", class => "invalid")
      }
   }
}

sub search_type {
   my ($type)=@_;
   if (defined (my $help=$type->help_topic)) {
      ($type->application != $application && $type->application->name.$outsuffix) . '#' . $topic2id{$help}->[0]
   } else {
      ("#", class => "invalid")
   }
}

sub resolve_ref {
   my ($help, $ref)=@_;
   if ($ref =~ m{^ wiki: ([^\s\#]+) (\# \S+)? $}x ) {
      return "$wikiURL/$1".lc($2);
   }
   if ($ref =~ m{^ $id_re :// }xo) {
      return $ref;
   }

   my $func_help;
   if (defined (my $ovcnt=$help->annex->{function}) &&
       ($help->parent->category ? $help->parent->parent : $help->parent)->name ne "methods") {
      $func_help= $ovcnt ? $help->topics->{"overload#0"} : $help;
   }
   local_array($help->related, $application->help->related_objects($func_help)) if defined($func_help);
   search($help, $ref);
}

sub write_descr {
   my ($writer, $help, $optional)=@_;
   if ($help->text =~ /\S/) {
      $writer->startTag("description");
      writeHTML($writer, $help, $help->text, "p");
      $writer->endTag("description");
   } elsif (!$optional) {
      $writer->dataElement("description", "UNDOCUMENTED");
   }
}

sub write_descr_string {
   my ($writer, $help, $text)=@_;
   if ($text =~ /\S/) {
      $writer->startTag("description");
      writeHTML($writer, $help, $text, "div");
      $writer->endTag("description");
   }
}

sub convertDokuWiki {
   my ($writer, $help, $text)=@_;
   while ($text =~ m{\G (.*?) (?: (''|__|\*\*|//) (.*?) \2
                                | \[\[ (.*?) (?: \| (.*?) )? \]\]
                                | $ )
                    }xgs) {
      $writer->characters($1) if length($1);
      if (defined $2) {
         my @decor;
         if ($2 eq "''") {
            @decor=('code');
         } elsif ($2 eq "**") {
            @decor=('strong');
         } elsif ($2 eq "//") {
            @decor=('em', class => 'param');
         } else {
            @decor=('em', class => 'u');
         }
         $writer->startTag([ $xhtmlns, shift @decor ], @decor);
         convertDokuWiki($writer, $help, $3);
         $writer->endTag;
      } elsif (defined $4) {
         my ($ref, $text)=($4, $5);
         $ref =~ s/^\s* (.*?) \s*$/$1/x;
         $writer->startTag([ $xhtmlns, 'a' ], href => resolve_ref($help, $ref));
         if (defined $text) {
            convertDokuWiki($writer, $help, $text);
         } else {
            $writer->characters($ref);
         }
         $writer->endTag;
      }
   }
}

sub writeHTMLtext {
   my ($writer, $help, $text)=@_;
   my $verbatim=0;
   foreach (split m{(&$id_re; | </? (?: su[bp] ) >)}ox, $text) {
      if ($verbatim) {
         if (substr($_,0,1) eq "&") {
            $writer->getOutput->print($_);
         } elsif (substr($_,1,1) eq "/") {
            $writer->endTag;
         } else {
            /$id_re/o;
            $writer->startTag([ $xhtmlns, $& ]);
         }
      } elsif (length) {
         convertDokuWiki($writer, $help, $_);
      }
      $verbatim^=1;
   }
}

sub writeHTML {
   my ($writer, $help, $text, $para_tag)=@_;
   $writer->setDataMode(0);
   while ($text =~ /\G(.*?)(?:\n\n|\Z|((?=^ *\t)))/msg) {
      if (length($1)>1) {
	 $writer->startTag([ $xhtmlns, $para_tag ]);
	 writeHTMLtext($writer, $help, $1);
	 $writer->endTag;
      }
      if ($para_tag eq "p" && defined $2) {
	 $writer->startTag([ $xhtmlns, "blockquote" ]);
	 while ($text =~ /\G^ *\t(.*)\n/mgc) {
	    $writer->startTag([ $xhtmlns, "div" ]);
	    writeHTMLtext($writer, $help, $1);
	    $writer->endTag;
	 }
	 $writer->endTag;
      }
   }
   $writer->setDataMode(1);
}

sub write_function {
   my ($writer, $help, $ovcnt, @attrs)=@_;
   if (!@attrs) {
      @attrs=(name => $help->name, $xmlid => $topic2id{$help}->[0]);
      if ($ovcnt=$help->annex->{function}) {
	 foreach (0..$ovcnt) {
            my $ov_topic=$help->topics->{"overload#$_"};
            $attrs[-1]=$topic2id{$ov_topic}->[0] if $_;     # the first instance inherits the id of the common parent node
	    write_function($writer, $ov_topic, $_, @attrs);
	 }
	 return;
      }
   }

   $writer->startTag("function", @attrs);

   if (defined (my $tparams=$help->annex->{tparam})) {
      foreach (@$tparams) {
	 $writer->startTag("tparam", name => $_->[0]);
	 write_descr_string($writer, $help, $_->[1]);
	 $writer->endTag;
      }
   }
   if (defined (my $params=$help->annex->{param})) {
      foreach (@$params) {
	 $writer->startTag("param", name => $_->[1], type => $_->[0], href => resolve_ref($help,$_->[0]));
	 write_descr_string($writer, $help, $_->[2]);
	 $writer->endTag;
      }
   }
   if (defined (my $options=$help->annex->{options})) {
      foreach (@$options) {
         my $group_text=local_shift($_);
         if (length($group_text)) {
            $writer->startTag("options");
            write_descr_string($writer, $help, $group_text);
         }
         foreach my $opt (@$_) {
            $writer->startTag("option", name => $opt->[1], type => $opt->[0], href => resolve_ref($help,$opt->[0]));
            write_descr_string($writer, $help, $opt->[2]);
            $writer->endTag;
         }
         if (length($group_text)) {
            $writer->endTag;
         }
      }
   }
   if (defined (my $return=$help->annex->{return})) {
      $writer->startTag("return", type => $return->[0], href => resolve_ref($help,$return->[0]));
      write_descr_string($writer, $help, $return->[1]);
      $writer->endTag;
   }

   write_descr($writer, $help, $ovcnt);
   $writer->endTag("function");
}

sub write_property_type {
   my ($writer, $help)=@_;
   $writer->startTag("property-type", name => $help->name, $xmlid => $topic2id{$help}->[0]);
   write_descr($writer, $help);

   my $pkg=$application->pkg."::props::".$help->name;
   if (UNIVERSAL::can($pkg, "self")) {
      my $proto=$pkg->self;
      if (defined($proto->super)) {
         $writer->emptyTag("derived-from",
                           type => ($proto->super->application != $application && $proto->super->application->name."::").$proto->super->full_name, 
                           href => search_type($proto->super));
      }
   }
   if (defined (my $methods=$help->topics->{methods})) {
      $writer->startTag("user-methods");
      write_categories($writer, $methods, \&write_function);
      $writer->endTag("user-methods");
   }
   $writer->endTag("property-type");
}

sub write_property_contents {
   my ($writer, $help, $prop)=@_;
   write_descr($writer, $help);

   if (defined (my $properties=$help->topics->{properties})) {
      $writer->startTag("properties");
      write_categories($writer, $properties, sub { write_property(@_, $prop->type, []) });
      $writer->endTag("properties");
   }
   if (defined (my $methods=$help->topics->{methods})) {
      $writer->startTag("user-methods");
      write_categories($writer, $methods, \&write_function);
      $writer->endTag("user-methods");
   }
}

sub write_property {
   my ($writer, $help, $obj_proto, $perms)=@_;
   my $prop=$obj_proto->property($help->name);
   if ($prop->flags & $Core::Property::is_permutation) {
      push @$perms, $help;
      return;
   }

   my $type= $prop->flags & $Core::Property::is_locally_extended ? $prop->type->super->[1] : $prop->type;
   $writer->startTag("property", name => $help->name,
		     type => ($type->application != $application && $type->application->name."::").$type->full_name,
		     href => search_type($type),
		     $xmlid => $topic2id{$help}->[0]);
   write_property_contents($writer, $help, $prop);
   $writer->endTag("property");
}

sub write_permutation {
   my ($writer, $help, $obj_proto)=@_;
   my $prop=$obj_proto->property($help->name);

   $writer->startTag("permutation", name => $help->name, $xmlid => $topic2id{$help}->[0]);
   write_property_contents($writer, $help, $prop);
   $writer->endTag("permutation");
}

sub write_object {
   my ($writer, $help)=@_;
   $writer->startTag("object", name => $help->name, $xmlid => $topic2id{$help}->[0]);

   if (my ($obj_proto)=grep { $_->help_topic == $help } @{$application->object_types}) {
      write_descr($writer, $help, @{$obj_proto->super} && $obj_proto->name eq $obj_proto->super->[0]->name);
      my %shown_super_types;
      foreach my $super (@{$obj_proto->super}) {
	 if (defined($super->help_topic) && !$shown_super_types{$obj_proto->name}++) {
	    $writer->emptyTag("derived-from",
                              object => ($super->application != $obj_proto->application && $super->application->name."::").$super->full_name,
                              href => search_type($super));
	 }
      }

      if (defined (my $properties=$help->topics->{properties})) {
         my @perms;
	 $writer->startTag("properties");
	 write_categories($writer, $properties, sub { write_property(@_, $obj_proto, \@perms) });
	 $writer->endTag("properties");

         if (@perms) {
            $writer->startTag("permutations");
            write_permutation($writer, $_, $obj_proto) for @perms;
            $writer->endTag("permutations");
         }
      }
   } else {
      write_descr($writer, $help, 1);
   }

   if (defined (my $methods=$help->topics->{methods})) {
      $writer->startTag("user-methods");
      write_categories($writer, $methods, \&write_function);
      $writer->endTag("user-methods");
   }
   $writer->endTag("object");
}

sub write_categories {
   my ($writer, $help, $write_sub, %taboo)=@_;
   foreach my $topic (grep { $_->category && !$taboo{$_->name} } values %{$help->topics}) {
      $writer->startTag("category", name => $topic->name, $xmlid => $topic2id{$topic}->[0]);
      write_descr($writer, $topic, 1);
      write_categories($writer, $topic, $write_sub);
      $writer->endTag("category");
   }
   foreach (@{$help->toc}) {
      my $topic=$help->topics->{$_};
      unless ($topic->category) {
	 $write_sub->($writer,$topic);
      }
   }
}

sub open_doc_file {
   my ($filename, %namespaces)=@_;
   $namespaces{$pmdocns}="";
   open my $out, ">$outdir/$filename" or die "can't create file $outdir/$filename: $!\n";
   my $writer=new Core::XMLwriter($out, PREFIX_MAP => \%namespaces, FORCED_NS_DECLS => [ keys %namespaces ]);
   $writer->xmlDecl;
   $writer
}

sub close_doc_file {
   my $writer=shift;
   $writer->end;
   close($writer->getOutput);
}

#############################################################################################
#
#  main function goes on

foreach my $app (@ARGV) {
   assign_ids(application($app));
}

foreach my $app (@ARGV) {
   application($app);
   my $writer=open_doc_file($application->name.".xml", $xhtmlns=>"html");
   $writer->getOutput->print(<<'.');
<!DOCTYPE application [
  <!ENTITY % HTMLsymbol PUBLIC "-//W3C//ENTITIES Symbols for XHTML//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml-symbol.ent">
  <!ENTITY % HTMLlat1   PUBLIC "-//W3C//ENTITIES Latin 1 for XHTML//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml-lat1.ent">
  %HTMLsymbol; %HTMLlat1;
]>
.
   $writer->startTag( [ $pmdocns, "application" ], name => $application->name );

   write_descr($writer, $application->help);

   if (@{$application->import_sorted}) {
      $writer->startTag("imports-from");
      $writer->emptyTag("application", name => $_) for @{$application->import_sorted};
      $writer->endTag("imports-from");
   }

   if (my @uses=grep { ! exists $application->imported->{$_} } keys %{$application->used}) {
      $writer->startTag("uses");
      $writer->emptyTag("application", name => $_) for @uses;
      $writer->endTag("uses");
   }

   if (defined (my $types=$application->help->topics->{property_types})) {
      $writer->startTag("property-types");
      write_categories($writer, $types, \&write_property_type);
      $writer->endTag("property-types");
   }

   if (defined (my $objects=$application->help->topics->{objects})) {
      $writer->startTag("objects");
      write_categories($writer, $objects, \&write_object);
      $writer->endTag("objects");
   }

   if (defined (my $functions=$application->help->topics->{functions})) {
      if (@{$functions->toc}) {
	 $writer->startTag("user-functions");
	 write_categories($writer, $functions, \&write_function, Basic => 1, Interactive => 1);
	 $writer->endTag("user-functions");
      }
   }

   $writer->endTag("application");
   close_doc_file($writer);
}


# Local Variables:
# mode: perl
# cperl-indent-level: 3
# End:
