#  Copyright (c) 1997-2015
#  Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Berlin, Germany)
#  http://www.polymake.org
#
#  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.
#-----------------------------------------------------------------------------
#
#  Extracting pieces of documentation into XML files
#

require Polymake::Core::InteractiveHelp;
$Polymake::Core::InteractiveHelp::store_provenience=1;

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

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

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

my $pmdocns="http://www.polymake.org/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;
my %bare_names_by_app;

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

#create an id as a mangling of the name
sub id_mangled {
   my ($help, $app, $id) = @_;
   my $r = $help->name;

   if (defined($help->topics->{"overload#0"}) && defined(my $params = $help->topics->{"overload#0"}->annex->{param})) {
      foreach (@$params) { $r .= "__".$_->[0]; }
   }

   if (index($r, "overload") != -1) {
      $r="";
      if (defined(my $params = $help->annex->{param})) {
         foreach (@$params) { $r .= "__".$_->[0]; }
      }
   }

   # in case of a category we have to append the parent (methods, properties, property_types, objects or functions) to keep it unique
   my $p = $help;
   if ($p->category) {
      $r=$p->parent->name."__".$r;
   }

   # append the name of the parent unless it is a category or property_types, objects, ...
   while ($p = $p->parent) {
      my $name = $p->name;
      if ($name && $name ne "property_types" && $name ne "objects" && $name ne "properties" && $name ne "methods" && $name ne "functions" && !$p->category) {
         $r = $name."__".$r;
      }
   }

   # people are using strange symbols...
   $r =~ s/\?/_questionmark/g;
   $r =~ s/\!/_exclamationmark/g;
   # spaces, # and :: are replaced by _
   # <...> is replaced by _...
   $r =~ s/[ #<]|::/_/g;
   $r =~ s/[>,\/]//g;
   # (...) is replaced by ...
   $r =~ s/\(.*\)//g;
   # we don't want more than two consecutive underscores
   $r =~ s/____/__/g;


   # if $r is empty, we are at the root
   unless ($r) {
      $r = $app->name;
   }

   # functions with name overload#0 won't have their real name in the mangling,
   # to make them unique append the old consecutive number (doesn't look nice but they don't occur in the documentation anyway)
   if ($help->name eq "overload#0") {
      $r .= "__$id";
   }

   if ($r eq $help->name) {
      # overloaded functions instances may appear in different categories, escaping the "overload#X" adornments
      if (my $repeated=($bare_names_by_app{$app->name} //= { })->{$r}++) {
         $r .= "__INST$repeated";
      }
   }

   return $r;
}

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

sub matching_topic {
   my ($topic, $word)=@_;
   $topic->name eq $word and
   length($topic->text) || grep { exists $topic->annex->{$_} } qw(param tparam return options property)
}

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

   do {
      foreach my $topic ($help, @{$help->related}) {
         if (matching_topic($topic, $word)) {
            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 { matching_topic($_, $word) ? ($_) : $_->find("!rel", $word) } grep { !exists $taboo{$_} } values %{$help->topics})) {
         @found=select_closest($_[0], @found) if @found>1;
         $searchTree{$_}->{$word}=\@found for @ancestors;
         return @found;
      }
      foreach my $topic (@{$help->related}) {
         if (my @found=$topic->find("!rel", $word)) {
            @found=select_closest($_[0], @found) if @found>1;
            $searchTree{$_}->{$word}=\@found for @ancestors;
            return @found;
         }
      }
      $taboo{$help}=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 =~ /[.:]/ && $what =~ /^ (?: ($id_re)::)? ($hier_id_re) $/xo) {
      if ($1 eq "Core" || $1 eq "Visual") {
         @topics=@how ? $app->help->find(@how, $what) : search_in_tree($help, $what);
      } elsif ($1 eq "props") {
         @topics=$app->help->find(@how, "property_types", $2);
      } else {
         # (ObjectType::)SUBOBJECT.PROPERTY
         @topics= defined($1) ? $app->help->find(@how, "objects", $1) : uniq( grep { defined } map { $_->help_topic } @{$app->object_types} );
         foreach my $prop_name (split /\./, $2) {
            @topics=uniq( grep { defined } map { $_->find("?rel", "properties", $prop_name) } @topics );
         }
         @topics=select_closest($app->help, @topics) if @topics>1;
      }
   }
   if (!@topics  &&
       $what =~ /^(?: # qual_id_re is greedy, it would swallow the method name
                      (?'objtype' $id_re (?: ::$id_re)* )::(?'method' [^:]+) $
                      # match parametrized types
                    | (?'objtype' $type_re)::(?'method' [^:]+) $
                  ) /xo  &&
       defined ($obj_help=$app->help->find(@how, "objects", "property_types", $+{objtype}))) {
      # Qualified::Type::METHOD
      @topics=$obj_help->find("?rel", $+{method});
   }
   if (!@topics) {
      # try as a single term
      @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) {
      die "Ambiguous reference to $_[1] from ", $application->name, "::", $help->full_path, "; candidates are:\n",
          (map { "    ".$_->full_path."\n" } @topics),
          "Please disambiguate by qualification with application name and/or object type at ", $help->defined_at, "\n";

   } elsif ($_[1] =~ /^($qual_id_re) \s*<\s* $types_re \s*>$/xo) {
      search($help, $1);
   } else {
      die "Unresolved reference to $_[1] from ", $application->name, "::", $help->full_path, "\n",
          $_[1] =~ /[<>]/ ? "Please remove the type parameters, because help topics are not stored with specializations"
                          : "Please double-check the spelling and/or qualify with application name or object type",
          " at ", $help->defined_at, "\n";
   }
}

sub ref_to_type {
   my ($referrer, $type)=@_;
   if (defined (my $help=$type->help_topic)) {
      if (defined (my $id_app=$topic2id{$help})) {
         return ($type->application != $application && $type->application->name.$outsuffix) . '#' . $id_app->[0];
      }
   }
   if ($type->abstract) {
      return '#';
   }
   die "Help topic ", $referrer->full_path, " defined at ", $referrer->defined_at, " refers to a ",
       (instanceof Core::ObjectType::Specialization($type) ? ("specialization ", $type->full_name) :
        instanceof Core::ObjectType($type) ? ("big object type ", $type->full_name) :
        instanceof Core::PropertyType($type) ? ("property type ", $type->full_name) :
        ("perl class ", ref($type))), " not represented in the help topic tree\n";
}

sub ref_to_topic {
   my ($topic)=@_;
   '#' . $topic2id{$topic}->[0]
}

my %ignore_types;
@ignore_types{qw(ARRAY SCALAR HASH Any enum)}=();

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

      for (my $topic=$help; defined($topic); $topic=$topic->parent) {
         if (defined (my $tparams=$topic->annex->{tparam})) {
            if (grep { $_->[0] eq $ref } @$tparams) {
               return '#';
            }
         }
         if (defined (my $params=$topic->annex->{param})) {
            if (grep { $_->[0] =~ /^$id_re<.*\b$ref\b.*>$/ } @$params) {
               return '#';
            }
         }
      }

      $ref =~ s/^(Object(?:Type)?)$/Core::$1/;
   }

   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, 1));
         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] ) > | </span> | < (?: span (?:\s+ $id_re = ".*")?) > )}ox, $text) {
      if ($verbatim) {
         if (substr($_,0,1) eq "&") {
            $writer->getOutput->print($_);
         } elsif (substr($_,1,1) eq "/") {
            $writer->endTag;
         } else {
            $_ =~ /<( $id_re )(?:\s? ( $id_re )="(.*)" )?>/xo;
            #/$id_re/o;
            if (defined($2)){
                $writer->startTag([ $xhtmlns, $1 ], $2=>$3);
            } else {
                $writer->startTag([ $xhtmlns, $1 ]);
            }
         }
      } 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_type_params {
   my ($writer, $help)=@_;
   if (defined (my $tparams=$help->annex->{tparam})) {
      foreach (grep { @$_>1 } @$tparams) {
         $writer->startTag("tparam", name => $_->[0]);
         write_descr_string($writer, $help, $_->[1]);
         $writer->endTag;
      }
   }
}

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 1;
      }
   }

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

   if (defined (my $params=$help->annex->{param})) {
      foreach (@$params) {
         $writer->startTag("param", name => $_->[1], type => $_->[0], href => resolve_ref($help, $_->[0]));
         my $descr=$_->[2];
         my $value_list=$_->[3];
         if ($descr =~ /\S/ || defined($value_list)) {
            $descr .= "\nPossible values:\n" if defined($value_list);
            $writer->startTag("description");
            writeHTML($writer, $help, $descr, "div");
            if (defined $value_list) {
               $writer->setDataMode(0);
               $writer->startTag([ $xhtmlns, "dl" ]);
               foreach my $value (@$value_list) {
                  $writer->startTag([ $xhtmlns, "dt" ]);
                  writeHTMLtext($writer, $help, $value->[0]);
                  $writer->endTag;
                  $writer->startTag([ $xhtmlns, "dd" ]);
                  writeHTMLtext($writer, $help, $value->[1]);
                  $writer->endTag;
               }
               $writer->endTag;
               $writer->setDataMode(1);
            }
            $writer->endTag("description");
         }
         $writer->endTag;
      }
   }
   if (defined (my $options=$help->annex->{options})) {
      foreach my $opt_group (@$options) {
         if (is_object($opt_group)) {
            my $id_app=$topic2id{$opt_group};
            $writer->emptyTag("common-option-list", name => $opt_group->name,
                              href => $id_app ? ($id_app->[1] != $application && $id_app->[1]->name.$outsuffix) . '#' . $id_app->[0]
                                              : '#', class => "invalid");
         } else {
            my $group_text=local_shift($opt_group);
            if (length($group_text)) {
               $writer->startTag("options");
               write_descr_string($writer, $help, $group_text);
            }
            foreach my $opt (@$opt_group) {
               $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("options");
            }
         }
      }
   }
   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;
   }

   if (defined (my $author=$help->annex->{author})) {
      $writer->emptyTag("author", name => $author);
   }

   if (defined (my $spez=$help->annex->{spez})) {
      $writer->emptyTag("only", name => $spez->name, href => ref_to_topic($spez));
   }

   if (defined (my $depends=$help->annex->{depends})) {
      $writer->emptyTag("depends", name => "$depends");
   }

   if (defined (my $examples=$help->annex->{examples})) {
      $writer->startTag("examples");
      write_examples($writer,$help,$examples);
      $writer->endTag;
   }

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

sub write_option_list {
   my ($writer, $help)=@_;
   $writer->startTag("common-option-list", name => $help->name, $xmlid => $topic2id{$help}->[0]);
   write_descr($writer, $help);

   if (@{$help->related}) {
      $writer->startTag("imports-from");
      foreach my $topic (@{$help->related}) {
         my $id_app=$topic2id{$topic};
         $writer->emptyTag("common-option-list", name => $topic->name,
                           href => $id_app ? ($id_app->[1] != $application && $id_app->[1]->name.$outsuffix) . '#' . $id_app->[0]
                                           : '#', class => "invalid");
      }
      $writer->endTag("imports-from");
   }

   foreach my $key (@{$help->annex->{keys}}) {
      $writer->startTag("option", name => $key->[1], type => $key->[0], href => resolve_ref($help, $key->[0]));
      write_descr_string($writer, $help, $key->[2]);
      $writer->endTag;
   }

   $writer->endTag("common-option-list");
}

sub write_property_type {
   my ($writer, $help)=@_;

   my $pkg=$application->pkg."::props::".$help->name;
   my @ext;
   if (UNIVERSAL::can($pkg, "self")) {
      my $proto=$pkg->self;
      @ext = ext_attr($proto);
   }
   $writer->startTag("property-type", name => $help->name, @ext, $xmlid => $topic2id{$help}->[0]);
   write_type_params($writer, $help);
   write_descr($writer, $help);

   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 => ref_to_type($help, $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)=@_;
   write_descr($writer, $help);

   if (defined (my $depends=$help->annex->{depends})) {
      $writer->emptyTag("depends", name => "$depends");
   }

   if (defined (my $examples=$help->annex->{examples})) {
      $writer->startTag("examples");
      write_examples($writer,$help,$examples);
      $writer->endTag;
   }

   if (defined (my $properties=$help->topics->{properties})) {
      $writer->startTag("properties");
      write_categories($writer, $properties, \&write_property);
      $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_examples {
   my ($writer,$help,$examples) = @_;
   foreach my $ex (@$examples) {
      $writer->startTag("example");
      $writer->startTag("description");
      $writer->setDataMode(0);
      my @buffer;
      foreach my $line (split "\n",$ex) {
         # match > or | at the beginning but check > with lookahead to keep it in $'
         if ($line =~ /^\s* (?: \| | (?= > ) ) /x) {
            $line = $';
            # escapes for html output, we dont want to parse the code sections as descriptions
            # due to stuff like [[1,2,3]] and to avoid [[]] around all types,...
            $line =~ s/&/&amp;/g;
            $line =~ s/</&lt;/g;
            $line =~ s/>/&gt;/g;
            if (@buffer > 0) {
               writeHTMLtext($writer,$help,join("\n",@buffer));
               @buffer = ();
            }
            # empty code tags cause display problems
            $line = " " if ($line eq "");
            $writer->startTag([ $xhtmlns, "code" ]);
            $writer->getOutput->print($line);
            $writer->endTag;
         } else {
            push @buffer,$line;
         }
      }
      writeHTMLtext($writer,$help,join("\n",@buffer)) if (@buffer > 0);
      $writer->setDataMode(1);
      $writer->endTag;
      $writer->endTag;
   }
}

sub write_property {
   my ($writer, $help)=@_;
   my $prop=$help->annex->{property};
   my $type=$prop->type;

   $writer->startTag("property", name => $help->name,
                     type => ($type->application != $application && $type->application->name."::").$type->full_name,
                     href => ref_to_type($help, $type),
                     ext_attr($prop),
                     $xmlid => $topic2id{$help}->[0]);

   if (defined (my $spez=$help->annex->{spez})) {
      $writer->emptyTag("only", name => $spez->name, href => ref_to_topic($spez));
   }
   write_property_contents($writer, $help);
   $writer->endTag("property");
   1
}

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

sub write_object {
   my ($writer, $help)=@_;
   my $obj_proto=$help->annex->{type};

   $writer->startTag("object", name => $help->name, $xmlid => $topic2id{$help}->[0],
                               defined($obj_proto) ? ext_attr($obj_proto) : ());
   write_type_params($writer, $help);

   if (defined (my $spezs=$help->topics->{specializations})) {
      foreach my $s (@{$spezs->topics}{@{$spezs->toc}}) {
         $writer->startTag("specialization", name => $s->name, $xmlid => $topic2id{$s}->[0]);
         write_descr($writer, $s, 1);
         $writer->endTag;
      }
   }

   if (defined $obj_proto) {
      write_descr($writer, $help, defined($obj_proto->generic));
      my %shown_super_types;
      foreach my $super (@{$obj_proto->super}) {
         if (defined($super->help_topic) && !instanceof Core::ObjectType::Specialization($super) && !$shown_super_types{$obj_proto->name}++) {
            $writer->emptyTag("derived-from",
                              object => ($super->application != $obj_proto->application && $super->application->name."::").$super->full_name,
                              href => ref_to_type($help, $super));
         }
      }

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

      if (defined (my $perms=$help->topics->{permutations})) {
         $writer->startTag("permutations");
         write_categories($writer, $perms, \&write_permutation);
         $writer->endTag("permutations");
      }
   } else {
      if (defined (my $super=$help->annex->{super})) {
         $writer->emptyTag("derived-from",
                           object => $super,
                           href => resolve_ref($help, $super));
      }
      write_descr($writer, $help, 1);
   }

   if (defined (my $examples=$help->annex->{examples})) {
      $writer->startTag("examples");
      write_examples($writer,$help,$examples);
      $writer->endTag;
   }

   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)=@_;
   my $has_categories;
   foreach my $topic (grep { $_->category && !$taboo{$_->name} } values %{$help->topics}) {
      $has_categories=1;
      $writer->startTag("category", name => $topic->name, ext_attr_dir($topic), $xmlid => $topic2id{$topic}->[0]);
      write_descr($writer, $topic);
      unless (@{$topic->toc}) {
         warn_print( "Category without items: ", $application->name, "::", $topic->full_path );
      }
      foreach (@{$topic->toc}) {
         $write_sub->($writer, $topic->topics->{$_});
      }
      $writer->endTag("category");
   }
   foreach (@{$help->toc}) {
      next if $_ eq "any";
      my $topic=$help->topics->{$_};
      unless ($topic->category) {
         if ($has_categories) {
            warn_print( "Item without category: ", $application->name, "::", $topic->full_path);
         }
         $write_sub->($writer, $topic);
      }
   }
}

sub ext_attr {
   my ($thing)=@_;
   if (defined $thing->extension) {
      (ext=>$thing->extension->URI, ext_name=>$thing->extension->short_name)
   } else {
      ()
   }
}

sub ext_attr_dir {
   my ($help)=@_;
   my $dir = $help->defined_at;
   $dir =~ s@/apps/$id_re/(?:rules|src)/\S+, line \d+$@@o;
   if (my $e = $Core::Extension::registered_by_dir{$dir}) {
      (ext => $e->URI, ext_name => $e->short_name)
   } else {
      ()
   }
}

sub ext_attr_app {
   my ($app)=@_;
   my $dir = $app->top;
   $dir =~ s@/apps/$id_re$@@o;
   if (my $e = $Core::Extension::registered_by_dir{$dir}) {
      (ext => $e->URI, ext_name => $e->short_name)
   } else {
      ()
   }
}

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

map { assign_ids($_) } map { application($_) } @ARGV;

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, ext_attr_app($application) );

   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 $types=$application->help->topics->{options})) {
      $writer->startTag("common-option-lists");
      write_categories($writer, $types, \&write_option_list);
      $writer->endTag("common-option-lists");
   }

   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);

   if ($app eq "common") {
      $writer=open_doc_file("core.xml", $xhtmlns=>"html");
      $writer->startTag( [ $pmdocns, "application" ], name => "core" );
      write_descr_string($writer, $application->help, <<'.');
Core functionality available in all applications.
.

      #TODO: document Core::Object methods and list them here

      my $functions=$application->help->topics->{functions};
      if (@{$functions->toc}) {
         $writer->startTag("user-functions");
         foreach my $topic (grep { defined } @{$functions->topics}{qw(Basic Interactive)}) {
            $writer->startTag("category", name => $topic->name, ext_attr_dir($topic), $xmlid => $topic2id{$topic}->[0]);
            write_descr($writer, $topic, 1);
            foreach (@{$topic->toc}) {
               write_function($writer, $topic->topics->{$_});
            }
            $writer->endTag("category");
         }
         $writer->endTag("user-functions");
      }

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


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