#  Copyright (c) 1997-2018
#  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.
#-----------------------------------------------------------------------------
#
#  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 JSON;
require Polymake::Core::InteractiveHelp;

$Polymake::Core::InteractiveHelp::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 { $top_help->related_objects($_) } ($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) : $help->find_in_tree($ref);
      } elsif ($1 eq "props") {
         @topics = $top_help->find(@how, "property_types", $2);
      } else {
         # (ObjectType::)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 = $top_help->select_closest(@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
      @topics = @how ? $top_help->find(@how, $ref) : $help->find_in_tree($ref);
   }

   choose_single_topic($help, $_[1], "term", 0, @topics);
}
####################################################################
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 ", $_[0]->full_path, " defined at ", $_[0]->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 ", $_[0]->full_path, " defined at ", $_[0]->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 SCALAR HASH CODE Any);

sub find_simple_type {
   my ($help, $type, $try_only, @where) = @_;
   if ($type =~ /^$id_re$/o) {
      if ($ignore_types{$type}) {
         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 (grep { $_->[0] eq $type } @$tparams) {
                  return $obj_topic->full_path . "/tparams/$type";
               }
            }
         }
      }
   }
   my $top_help = defined($application) ? $application->help : $Core::Help::core;
   if ($type =~ /^($id_re)::($type_re)$/o) {
      if ($1 eq "props") {
         @where = qw(property_types);
         $type = $2;
      } elsif ($1 eq "objects") {
         @where = qw(objects);
         $type = $2;
      } elsif ($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_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::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" );
         ++$errors;
      }
      undef
   }
}
####################################################################
sub add_type_params {
   my ($tree, $help) = @_;
   if (defined(my $tparams = $help->annex->{tparam})) {
      if (my @tparams = map { { name => $_->[0],
                                '$text' => process_text($help, $_->[1]) } }
                        grep { @$_>1 } @$tparams) {
         $tree->{tparams} = \@tparams;
      }
   }
}
####################################################################
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_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 . "::props::" . $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 ];
      }
   }
   add_type_params($tree, $help);
   if (defined(my $methods = $help->topics->{methods})) {
      $tree->{methods} = process_categories($methods, \&process_function);
   }
   add_examples($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 => $_->[1],
                             type => find_type($help, $_->[0], qw(property_types objects options)),
                             '$text' => process_text($help, $_->[2]) } }
                         @{$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;
}
####################################################################
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::ObjectType::Augmented($_) && !instanceof Core::InteractiveHelp::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::ObjectType::Specialization($_) && !$shown_super_types{$_->name}++ && $_ != $proto->generic }
          @{$proto->super}) {
         $tree->{derived_from} = \@derived_from;
      }
      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);
   $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 => $_->[1],
              type => find_type($help, $_->[0]),
              '$text' => process_text($help, $_->[2]),
              defined($_->[3]) ? ( values => { map { ($_->[0] => process_text($help, $_->[1])) } @{$_->[3]} } ) : ()
            } } @$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->[1]),
                             type => find_type($help, $return->[0]) };
      }
      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);
   }
   $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(@_);
   local push @{$application->help->related}, $Core::Help::core;

   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->import_sorted}) {
      $tree->{imports} = $application->import_sorted;
   }
   if (my @uses = grep { ! exists $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";
}
my $JSON = new JSON;
my $result = $JSON->encode($tree);
if (!$Main::standalone_script && !@ARGV && defined(wantarray)) {
   return $result;
}
my $out;
if (!@ARGV || $ARGV[0] eq "-") {
   $out = \*STDOUT;
} else {
   open $out, ">", $ARGV[0] or die "can't create result file $ARGV[0]; $!\n";
}
print $out $result;


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