#  Copyright (c) 1997-2007
#  Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Berlin, Germany)
#  http://www.math.tu-berlin.de/polymake,  mailto:polymake@math.tu-berlin.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: Help.pm 7560 2007-01-15 14:04:09Z gawrilow $

use strict;
use namespaces;

# A "virtual" package:
# per default offers dummy methods which do not store anything.
# Should be redefined when needed

package Poly::Help;

my $dummy=bless [ ];

sub clone { $dummy }
sub add {}
*add_function=\&add;
*merge=\&add;
sub get { undef }

my $impl;
sub redefine { $impl=$_[1] }

sub new {
   if ($impl) {
      shift;
      $impl->new(@_);
   } else {
      $dummy;
   }
}

#################################################################################
#
#  Help class designed for interactive shell
#
package Poly::InteractiveHelp;

use Struct (
   [ new => ';$$$' ],
   [ '$name' => '#2' ],
   '$category',
   [ '$text' => '#3' ],
   '@toc',
   '%topics',
);

# between several entries with the same topic path
declare $separator="-----\n";

sub sanitize {
   $_[0] =~ s/^\s*\#//gm;
   $_[0] =~ s/^\#+\n//gm;
   $_[0] =~ s/^(?:\s*\\|[ \t]+)$//gm;
   $_[0] =~ s/\n{3,}/\n\n/gs;
   $_[0] =~ s/^\s+\n//s;
   $_[0] =~ s/\n{2,}$/\n/s;
}

#################################################################################
my $stripped=qr{ [ \t]* (.*(?<!\s)) [ \t]*\n }xm;

sub add {
   my ($self, $path, $text, $split_multi)=@_;
   $path=[ split m'/', $path ] unless ref $path;
   if ($path->[0] eq '$this') {
      splice @$path, 0, 1, 'objects', caller()->prototype->name;
   }
   my ($cat, $author);
   if ($text =~ s/^\#?\s* category: $stripped//xomi) {
      splice @$path, -1, 0, $1;
      $cat=1;
   }
   if ($text =~ s/^\#?\s* author: $stripped//xomi) {
      $author=$1;
   }
   sanitize($text);
   return undef unless $text =~ /\S/;

   if (@$path) {
      my $topic=pop @$path;
      foreach (@$path) {
	 if (defined (my $h=$self->topics->{$_})) {
	    $self=$h;
	 } else {
	    push @{$self->toc}, $_;
	    $self=$self->topics->{$_}=new Help($self, $_);
	 }
      }
      $self->category ||= $cat;

      if (defined (my $h=$self->topics->{$topic})) {
	 if (!$split_multi) {
	    if (length($h->text)) {
	       $h->text .= $separator . $text;
	    } else {
	       $h->text=$text;
	    }
	    return $h;
	 }
	 if (exists $h->topics->{"$split_multi#0"}) {
	    $self=$h;
	    $topic="$split_multi#".scalar @{$self->toc};
	 } else {
	    $self=$self->topics->{$topic}=new Help($self, $topic);
	    $h->name="$split_multi#0";
	    $self->topics->{$h->name}=$h;
	    $topic="$split_multi#1";
	 }
      } else {
	 push @{$self->toc}, $topic;
      }

      $self=($self->topics->{$topic}=new Help($self, $topic, $text));

   } else {
      if (length($self->text)) {
	 $self->text .= $separator . $text;
      } else {
	 $self->text=$text;
      }
   }

   if ($author) {
      $self->topics->{author}=new Help($self, "author", $author);
   }
   return $self;
}
#################################################################################

my $continued_text=qr{ [ \t]* (.* \n             	  # rest of the first line
		       (?: (?:^\#?[ \t]*\n)*          	  # empty lines in between
			   ^\#?(?:[ ]*\t[ \t]*|[ ]{6,})   # indented with tabs and/or more than 5 spaces
		           (?!\w+:) \S.* \n )*		  # and without new keyword at the beginning
		       ) }x;

sub add_function {
   my ($self, $path, $help_text)=@_;
   my (%annex, %options);
   while ($help_text =~ s/^\#?\s* (return|signature): \s*(.*)$//xm) {
      $annex{$1}=$2;
   }
   while ($help_text =~ s/^\#?\s* args: $continued_text//xom) {
      my $text=$1;
      sanitize($text);
      $text =~ s/^([^\n]+)\n+$/$1/s;	# if the visible text consists of a single line, chop the eol's.
      $annex{args}=$text;
   }
   while ($help_text =~ s/^\#?\s* option: \s* ($id_re) $continued_text//xom) {
      my ($name, $text)=($1, $2);
      sanitize($text);
      $options{$name}=new Help(undef, $name, $text);
      $annex{options}="";
   }

   if (my $h=$self->add($path, $help_text, $annex{signature} && "overload")) {
      while (my ($annex, $text)=each %annex) {
	 $h->topics->{$annex}=new Help($h, $annex, $text);
      }
      if (%options) {
	 $h->topics->{options}->topics=\%options;
      }
      $h
   }
}
#################################################################################
sub clone {
   my ($src, $up)=@_;
   my $self=new Help($up, $src->name, $src->text);
   @{$self->toc}=@{$src->toc};
   while (my ($name, $topic)=each %{$src->topics}) {
      $self->topics->{$name}=$topic->clone($self);
   }
   $self->category=$src->category;
   $self
}
#################################################################################
sub merge {
   my ($self, $src)=@_;
   if (length($src->text)) {
      if (length($self->text)) {
	 $self->text .= $separator . $src->text;
      } else {
	 $self->text=$src->text;
      }
   }
   my %added;
   while (my ($name, $src_topic)=each %{$src->topics}) {
      if (defined (my $topic=$self->topics->{$name})) {
	 merge($topic, $src->topics->{$name});
      } else {
	 $self->topics->{$name}=$src_topic->clone($self);
	 $added{$name}=1;
      }
   }
   push @{$self->toc}, grep { $added{$_} } @{$src->toc};
   $self->category|=$src->category;
}
#################################################################################
sub get_topic {
   my $self=shift;
   my $path= @_ > 1 ? \@_ : is_ARRAY($_[0]) ? shift  : [ split m'/', shift ];
   foreach (@$path) {
      $self=$self->topics->{$_} or last;
   }
   $self
}
#################################################################################
sub get {
   my $self=&get_topic;
   $self && $self->text
}

1