#  Copyright (c) 1997-2024
#  Ewgenij Gawrilow, Michael Joswig, and the polymake team
#  Technische Universität Berlin, Germany
#  https://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.
#-----------------------------------------------------------------------------
#
#  Extract inline documentation into a JSON file
#
#  When called as
#    $str=script("help2json");
#  returns the encoded JSON string.
#
#  When called in void context or as a standalone script from command line,
#  stores the JSON string in the given file or prints to STDOUT.

require Polymake::Core::Help::Topic;
require Polymake::Core::Shell::Completion;

$Polymake::Core::Help::Topic::store_provenience = true;

my $errors = 0;
my @apps;

if ( !GetOptions( 'applications=s' => sub { collect_arglist(\@apps, $_[1]) },
                )
     or @ARGV > 1 ) {
   die "usage: polymake --script help2json [--applications APP_NAME ... -- ] [ OUTPUT_FILE | - ]\n";
}

####################################################################
sub resolve_ref {
   my ($help, $ref) = @_;
   if ($ref =~ /[<>]/) {
      return &find_type;
   }
   if ($ref =~ /^$id_re$/o && defined(my $type_ref = find_simple_type($help, $ref, true))) {
      return $type_ref;
   }

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

   my $top_help = defined($app) ? $app->help : $Core::Help::core;
   local if (defined(my $ovcnt = $help->annex->{function})
               and
             ($help->parent->category ? $help->parent->parent : $help->parent)->name ne "methods") {
      local push @{$help->related},
                 map { related_objects($top_help, $_) } ($ovcnt ? @{$help->topics}{map {"overload#$_"} 0..$ovcnt} : $help);
   }

   my (@topics, $obj_help);
   if ($ref =~ /[.:]/ && $ref =~ /^ (?: ($id_re)::)? ($hier_id_re) $/xo) {
      if ($1 eq "Core" || $1 eq "Visual") {
         @topics = @how ? $top_help->find(@how, $ref) : select_closest($help, find_in_tree($help, $ref));
      } else {
         # (BigObjectType::)SUBOBJECT.PROPERTY
         @topics = defined($1) ? $top_help->find(@how, "objects", $1) : defined($app) ? 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($top_help, @topics) if @topics > 1;
      }
   }
   if (!@topics  &&
       $ref =~ /^(?: # 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 = $top_help->find(@how, "objects", "property_types", $+{objtype}))) {
      # Qualified::Type::METHOD
      @topics = $obj_help->find("?rel", $+{method});
   }
   if (!@topics) {
      # try as a single term
      if ((my @parts = split m{/}, $ref, 2) == 2){
         $ref = pop @parts;
         push @how, @parts;
      }
      @topics = @how ? $top_help->find(@how, $ref) : select_closest($help, find_in_tree($help, $ref));
   }

   choose_single_topic($help, $_[1], "term", 0, @topics);
}
#################################################################################
# => length of the path up to the first common ancestor
sub proximity {
   my ($from, $to) = @_;
   my %parents;
   do {
      $parents{$to} = 1;
   } while (defined($to = $to->parent));

   my $l = 0;
   do {
      return $l if exists $parents{$from};
      ++$l;
   } while (defined($from = $from->parent));

   undef
}

sub select_closest {
   my $from = shift;
   if (@_ > 1) {
      my @closest = @_;
      my $mindist = 100000000;
      foreach (@_) {
         if (defined (my $dist = proximity($from, $_))) {
            if ($dist < $mindist) {
               $dist = $mindist;
               @closest = ($_);
            } elsif ($dist == $mindist) {
               push @closest, $_;
            }
         }
      }
      @closest
   } else {
      @_
   }
}
#################################################################################
# guess the search context for a function:
# consider the first argument and the return type

sub related_objects {
   my ($help, $func_topic)=@_;
   my ($params, $return) = @{$func_topic->annex}{qw(param return)};
   uniq( map { $_, @{$_->related} }
         ( defined($params) ? $help->find("objects", $params->[0]->type) : (),
           defined($return) ? $help->find("objects", $return->type) : () ) )
}
####################################################################
# can be target of a cross-reference
sub is_addressable {
   my ($help) = @_;
   length($help->text) || grep { exists $help->annex->{$_} } qw(param tparam return options property)
}

sub find_in_tree {
   my ($help, $word) = @_;
   my $start = $help;
   my (%taboo, @descendants);
   do {
      foreach my $topic ($help, @{$help->related}) {
         if ($topic->name eq $word && is_addressable($topic)) {
            my $me = [ $topic ];
            $_->annex->{searchTree}->{$word} = $me for @descendants;
            return $topic;
         }
         if (defined(my $cached = $topic->annex->{searchTree}->{$word})) {
            $_->annex->{searchTree}->{$word} = $cached for @descendants;
            return @$cached;
         }
      }
      if (my @found = uniq( map { $_->name eq $word && is_addressable($_) ? ($_) : $_->find("!rel", $word) }
                            grep { !exists $taboo{$_} } values %{$help->topics})) {
         $_->annex->{searchTree}->{$word} = \@found for @descendants;
         return @found;
      }
      foreach my $topic (@{$help->related}) {
         if (my @found = $topic->find("!rel", $word)) {
            $_->annex->{searchTree}->{$word} = \@found for @descendants;
            return @found;
         }
      }
      $taboo{$help} = true;
      push @descendants, $help if $help != $start;
      $help = $help->parent;
   } while (defined $help);

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

####################################################################
sub where_is {
   my ($topic) = @_;
   my $parent = $topic->parent;
   if (defined($topic->annex->{function}) || defined($parent->annex->{function})) {
      "function"
   } else {
      $parent = $parent->parent if $parent->category;
      $parent->name
   }
}

sub choose_single_topic {
   my ($help, $ref, $what, $try_only, @topics) = @_;
   if (@topics == 1) {
      $topics[0]->full_path;
   } else {
      if (@topics == 2) {
         # there are annoying pairs of big object and property types with identical names; let's choose big objects by default
         my @kind = map { where_is($_) } @topics;
         if ($kind[0] eq "objects" && $kind[1] eq "property_types") {
            return $topics[0]->full_path;
         }
         if ($kind[1] eq "objects" && $kind[0] eq "property_types") {
            return $topics[1]->full_path;
         }
      }
      if (@topics) {
         err_print( "Help topic ", $help->full_path, " defined at ", $help->defined_at, " refers to an ambiguous $what $ref\n",
                    "Candidates are:\n",
                    (map { "  " . $_->full_path . "\n" } @topics),
                    "Please disambiguate by qualification with application name and/or big object type" );
         ++$errors;
      } elsif (!$try_only) {
         err_print( "Help topic ", $help->full_path, " defined at ", $help->defined_at, " refers to an unknown $what $ref\n",
                    "Please double-check the spelling and/or qualify with application name or big object type");
         ++$errors;
      }
      undef
   }
}
####################################################################
my %ignore_types = map { ($_ => true) } qw(ARRAY HASH CODE Any);

sub find_simple_type {
   my ($help, $type, $try_only, @where) = @_;
   if ($type =~ /^$id_re$/o) {
      if ($ignore_types{$type} || $type =~ s{^__(\w+)__$}{//$1//}) {
         return $type;
      }
      for (my $topic = $help; defined($topic); $topic = $topic->parent) {
         foreach my $obj_topic ($topic, @{$topic->related}) {
            if (defined(my $tparams = $obj_topic->annex->{tparam})) {
               if (my ($tparam_descr) = grep { $_->name eq $type } @$tparams) {
                  return defined($tparam_descr->text) ? $obj_topic->full_path . "/tparams/$type" : $type;
               }
            }
         }
      }
   }
   my $top_help = defined($application) ? $application->help : $Core::Help::core;
   if ($type =~ /^($id_re)::($type_re)$/o) {
      if ($1 eq "Core") {
         $top_help = $Core::Help::core;
      } elsif (defined (my $app = lookup Core::Application($1))) {
         $top_help = $app->help;
         $type = $2;
      }
   }
   if (!@where) {
      @where = qw(property_types objects);
   }
   choose_single_topic($help, $_[1], "type", $try_only, $top_help->find(@where, $type));
}
####################################################################
sub find_type {
   my ($help, $type, @where) = @_;
   $type =~ s{$qual_id_re}{ find_simple_type($help, $&, false, splice @where) }roge;
}
####################################################################
sub process_text {
   my ($help, $text) = @_;
   $text //= $help->text;
   $text =~ s{\[\[ \s*\K (?!(?:wiki|https?|ftp):) (.*?) \s* (?= (?: \| .*?)? \]\])}{ resolve_ref($help, $1) }xge;
   $text
}
####################################################################
sub ref_to_simple_type {
   my ($referrer, $type) = @_;
   if (defined (my $help = $type->help_topic)) {
      $help->full_path
   } else {
      unless ($type->abstract) {
         err_print( "Help topic ", $referrer->full_path, " defined at ", $referrer->defined_at, " refers to a ",
                    (instanceof Core::BigObjectType::Specialization($type) ? ("specialization ", $type->full_name) :
                     instanceof Core::BigObjectType($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" );
         ++$errors;
      }
      undef
   }
}
####################################################################
sub ref_to_type {
   my ($referrer, $type) = @_;
   if (defined($type->params) and !$type->abstract || defined($type->generic)) {
      &ref_to_simple_type . "<" . join(",", map { ref_to_type($referrer, $_) } @{$type->params}) . ">"
   } elsif ($type->abstract && instanceof Core::ClassTypeParam($type)) {
      ref_to_simple_type($referrer, $type->context_pkg->typeof_gen) . "/tparams/" . $type->name
   } else {
      &ref_to_simple_type
   }
}
####################################################################
sub add_type_params {
   my ($tree, $help, $proto) = @_;
   if (defined(my $tparam_docs = $help->annex->{tparam})) {
      if (defined($proto) && defined($proto->params)) {
         my %described;
         $tree->{tparams} = [ map { $described{$_->name} = true;
                                    { name => $_->name, '$text' => process_text($help, $_->text) }
                              } @$tparam_docs ];
         if (my @undescribed = grep { not $described{$_->name} } @{$proto->params}) {
            err_print( "Type parameter", @undescribed > 1 && "s", " ", join(", ", @undescribed),
                       " without description in help topic ", $help->full_path, " defined at ", $help->defined_at );
            ++$errors;
         } elsif (keys(%described) != @{$proto->params}) {
            delete $described{$_->name} for @{$proto->params};
            err_print( '@tparam element', keys(%described) > 1 && "s", " ", join(", ", keys(%described)),
                       keys(%described) > 1 ? " do" : " does",
                       " not match type parameters in help topic ", $help->full_path, " defined at ", $help->defined_at );
            ++$errors;
         }
      } elsif (my @tparams = map { defined($_->text) ? { name => $_->name, '$text' => process_text($help, $_->text) } : () }
                                 @$tparam_docs) {
         $tree->{tparams} = \@tparams;
      }
   } elsif (defined($proto) && defined($proto->params) && @{$proto->params} > 0) {
      err_print( "Type parameter descriptions missing in help topic ", $help->full_path, " defined at ", $help->defined_at );
      ++$errors;
   }
}
####################################################################
sub process_example {
   my ($help, $example) = @_;
   my @portions;
   pos($example->body) = 0;
   while ($example->body =~ m{\G (?'text' (?: ^ [ \t]*+ [^>|] .*\n)*+)
                                 (?'in'   (?: ^ [ \t]* > .*\n)*+)
                                 (?'out'  (?: ^ [ \t]* \| .*\n)*+) }xmg) {
      my ($text, $in, $out) = @+{'text', 'in', 'out'};
      if ($text =~ /\S/ || length($in) > 0 || length($out) > 0) {
         push @portions, { '$text' => process_text($help, $text),
                           in  => $in  =~ s{^[ \t]*>}{}mgr,
                           out => $out =~ s{^[ \t]*\|}{}mgr };
      }
   }
   \@portions;
}
####################################################################
sub add_defined_at {
   my ($tree, $help) = @_;
   if (defined($help->defined_at)) {
      $tree->{defined_at} = $help->defined_at =~ s{$InstallTop/}{}r;
      $tree->{defined_at} =~ s{, line (\d+)}{:$1};
   }
}
####################################################################
sub add_examples {
   my ($tree, $help) = @_;
   if (my $examples = $help->annex->{examples}) {
      $tree->{examples} = [ map { process_example($help, $_) } @$examples ];
   }
}
####################################################################
sub process_property_type {
   my ($help) = @_;
   my $tree = { '$text' => process_text($help) };
   my $pkg = $application->pkg."::".$help->name;
   my $proto;
   if (defined(my $get_proto = UNIVERSAL::can($pkg, "self"))) {
      $proto = $get_proto->(1);
      if (defined($proto->extension)) {
         $tree->{ext} = $proto->extension->URI;
      }
      if (defined($proto->super) and defined(my $super_ref = ref_to_type($help, $proto->super))) {
         $tree->{derived_from} = [ $super_ref ];
      }
      if ($proto->abstract) {
         add_type_params($tree, $help, $proto);
      }
   } else {
      add_type_params($tree, $help);
   }
   if (defined(my $methods = $help->topics->{methods})) {
      $tree->{methods} = process_categories($methods, \&process_function);
   }
   add_examples($tree, $help);
   add_defined_at($tree, $help);
   $tree
}
####################################################################
sub process_option_list {
   my ($help) = @_;
   my $tree = { '$text' => process_text($help) };
   if (@{$help->related}) {
      $tree->{derived_from} = [ map { $_->full_path } @{$help->related} ];
   }
   $tree->{keys} = [ map { { name => $_->name,
                             type => find_type($help, $_->type, qw(property_types objects options)),
                             '$text' => process_text($help, $_->text) } }
                         @{$help->annex->{keys}} ];
   $tree
}
####################################################################
sub add_property_contents {
   my ($tree, $help) = @_;
   if (defined(my $properties = $help->topics->{properties})) {
      $tree->{properties} = process_categories($properties, \&process_property);
   }
   if (defined(my $methods = $help->topics->{methods})) {
      $tree->{methods} = process_categories($methods, \&process_function);
   }
   if (defined(my $depends = $help->annex->{depends})) {
      $tree->{depends} = $depends;
   }
   &add_examples;
   add_defined_at($tree, $help);
}
####################################################################
sub process_property {
   my ($help) = @_;
   my $prop = $help->annex->{property};
   my $tree = { };
   if ($prop->flags & Core::Property::Flags::is_augmented) {
      if (my @super = grep { instanceof Core::BigObjectType::Augmented($_) && !instanceof Core::Help::Topic::Specialization($_->help_topic) } @{$prop->type->super}) {
         $tree->{derived_from} = [ map { $_->help_topic->full_path } @super ];
      }
      $tree->{type} = ref_to_type($help, $prop->type->pure_type);
   } else {
      $tree->{'$text'} = process_text($help);
      $tree->{type} = ref_to_type($help, $prop->type);
   }
   if (defined($prop->extension)) {
      $tree->{ext} = $prop->extension->URI;
   }
   if (defined(my $spez_topic = $help->annex->{spez})) {
      $tree->{specialization} = $spez_topic->full_path;
   }
   add_property_contents($tree, $help);
   $tree
}
####################################################################
sub process_permutation {
   my ($help) = @_;
   my $tree = { '$text' => process_text($help) };
   add_property_contents($tree, $help);
   $tree
}
####################################################################
sub process_object {
   my ($help) = @_;
   my $tree = { '$text' => process_text($help) };
   if (defined(my $proto = $help->annex->{type})) {
      if (defined($proto->extension)) {
         $tree->{ext} = $proto->extension->URI;
      }
      if (defined (my $spezs = $help->topics->{specializations})) {
         foreach my $spez_topic (@{$spezs->topics}{@{$spezs->toc}}) {
            $tree->{specializations}->{$spez_topic->name} = { '$text' => process_text($spez_topic) };
         }
      }
      my %shown_super_types;
      if (my @derived_from =
             map { $_->help_topic->full_path }
             grep { defined($_->help_topic) && !instanceof Core::BigObjectType::Specialization($_) && !$shown_super_types{$_->name}++ && $_ != $proto->generic }
          @{$proto->super}) {
         $tree->{derived_from} = \@derived_from;
      }
      if ($proto->abstract) {
         add_type_params($tree, $help, $proto);
      }
      if (defined(my $properties = $help->topics->{properties})) {
         $tree->{properties} = process_categories($properties, \&process_property);
      }
      if (defined(my $perms = $help->topics->{permutations})) {
         $tree->{permutations} = process_categories($perms, \&process_permutation);
      }
   } else {
      if (defined(my $super = $help->annex->{super})) {
         $tree->{derived_from} = [ find_type($help, $super, "objects") ];
      }
      add_type_params($tree, $help);
   }
   if (defined(my $methods = $help->topics->{methods})) {
      $tree->{methods} = process_categories($methods, \&process_function);
   }
   add_examples($tree, $help);
   add_defined_at($tree, $help);
   $tree
}
####################################################################
sub process_function {
   my ($help) = @_;
   my $tree = { };
   if (my $ovcnt = $help->annex->{function}) {
      $tree->{overloads} = [ map { process_function($help->topics->{"overload#$_"}) } 0..$ovcnt ];
   } else {
      $tree->{'$text'} = process_text($help);

      my $dir = $help->defined_at =~ s{/apps/$id_re/(?:rules|src)/\S+, line \d+$}{}ro;
      if (my $ext = $Core::Extension::registered_by_dir{$dir}) {
         $tree->{ext} = $ext->URI;
      }

      add_type_params($tree, $help);

      if (defined(my $params = $help->annex->{param})) {
         $tree->{params} = [ map {
            { name => $_->name,
              type => find_type($help, $_->type),
              '$text' => process_text($help, $_->text),
              defined($_->values) ? ( values => { map { ($_->value => process_text($help, $_->text)) } @{$_->values} } ) : ()
            } } @$params ];
      }
      if (defined(my $options = $help->annex->{options})) {
         $tree->{options} = [ map {
            $_->parent != $help ? $_->full_path : process_option_list($_)
         } @$options ];
      }
      if (defined(my $return = $help->annex->{return})) {
         $tree->{return} = { '$text' => process_text($help, $return->text),
                             type => find_type($help, $return->type) };
      }
      if (defined(my $spez_topic = $help->annex->{spez})) {
         $tree->{specialization} = $spez_topic->full_path;
      }
      if (defined(my $depends = $help->annex->{depends})) {
         $tree->{depends} = $depends;
      }
      add_examples($tree, $help);
      add_defined_at($tree, $help);
   }
   $tree
}
####################################################################
sub process_categories {
   my ($help, $process_sub) = @_;
   my $tree = { };
   foreach my $cat_topic (grep { $_->category } values %{$help->topics}) {
      if (@{$cat_topic->toc}) {
         my $cat_tree = { '$category' => process_text($cat_topic) };
         foreach (@{$cat_topic->toc}) {
            $cat_tree->{$_} = $process_sub->($cat_topic->topics->{$_});
         }
         $tree->{$cat_topic->name} = $cat_tree;
      } else {
         err_print( "Category without items: ", $cat_topic->full_path );
         ++$errors;
      }
   }
   my $seen_categories = keys %$tree;
   foreach (@{$help->toc}) {
      next if $_ eq "any";
      my $topic = $help->topics->{$_};
      unless ($topic->category) {
         $seen_categories and warn_print( "Item without category: ", $topic->full_path );
         $tree->{"no category"}->{$_} = $process_sub->($topic);
      }
   }
   $tree
}
####################################################################
sub process_app {
   application(@_);

   my $tree = { '$text' => process_text($application->help) };

   if (my $ext = $Core::Extension::registered_by_dir{$application->top =~ s{/apps/$id_re$}{}or}) {
      $tree->{ext} = $ext->URI;
   }
   if (@{$application->linear_imported}) {
      $tree->{imports} = [ map { $_->name } @{$application->linear_imported} ];
   }
   if (my @uses = grep { !$application->imported->{$_} } keys %{$application->used}) {
      $tree->{uses} = \@uses;
   }
   if (defined(my $types = $application->help->topics->{property_types})) {
      $tree->{property_types} = process_categories($types, \&process_property_type);
   }
   if (defined(my $options = $application->help->topics->{options})) {
      $tree->{options} = process_categories($options, \&process_option_list);
   }
   if (defined(my $objects = $application->help->topics->{objects})) {
      $tree->{objects} = process_categories($objects, \&process_object);
   }
   if (defined(my $functions = $application->help->topics->{functions})) {
      if (@{$functions->toc}) {
         $tree->{functions} = process_categories($functions, \&process_function);
      }
   }
   $tree
}
####################################################################
sub process_core {
   local $application;
   local push @{$Core::Help::core->related}, application("common")->help;

   my $tree = { '$text' => <<'.' };
Core functionality available in all applications.
.
   if (defined (my $objects = $Core::Help::core->topics->{objects})) {
      $tree->{objects} = process_categories($objects, \&process_object);
   }
   if (defined (my $functions = $Core::Help::core->topics->{functions})) {
      if (@{$functions->toc}) {
         $tree->{functions} = process_categories($functions, \&process_function);
      }
   }
   $tree
}
######################### main function ############################
if (!@apps) {
   @apps = map { /$filename_re/o } glob "$InstallTop/apps/*";
}
add Core::Application($_) for @apps;

my $tree = { (map { ($_ => process_app($_)) } @apps ),
             core => process_core(),
           };

if ($errors > 0) {
   die "Encountered $errors error", ($errors>1 && "s"), ", generation aborted\n";
}
if (!$Main::standalone_script && !@ARGV && defined(wantarray)) {
   return encode_json($tree);
}
my $out;
if (!@ARGV || $ARGV[0] eq "-") {
   $out = \*STDOUT;
} else {
   open $out, ">", $ARGV[0] or die "can't create result file $ARGV[0]; $!\n";
}
write_json($out, $tree);


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