#  Copyright (c) 1997-2006
#  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: Struct.pm,v 1.20 2006/02/21 19:29:07 gawrilow Exp $

use integer;
use strict;
use Poly;
use namespaces 'Poly';

package Struct;
use Poly::Ext;
use Carp;

$Carp::Internal{Struct}=1;

sub import {
   shift;			# drop the own package name
   my $cnt=0;
   my ($pkg, $file, $line)=caller(0);
   if (my $def=$pkg->can(".defined")) {
      my $other_pkg=method_owner($def);
      if ($pkg eq $other_pkg) {
	 croak "package $pkg already declared as Struct at ".&$def.", conflicting declaration";
      } else {
	 croak "inheritance from package $other_pkg declared as Struct at ".&$def.
	       "\n seems to be established via plain \@ISA assignment and conflicts with Struct declaration";
      }
   }
   my $symtab=get_pkg($pkg);
   my $constructor="";
   my ($signature, $own_signature, $check_arg, $min_arg, $max_arg, $keyed_args, %keys, $keys_changed, $trailing_list, $super, $redefine);
   my $with_namespaces=namespaces::uses($pkg);
   my $prologue="use strict;\n" . (!$with_namespaces && "no namespaces;\n") . "package $pkg";
   while (ref($_[0])) {
      if ($_[0]->[0] eq '@ISA') {
	 my $isa=shift;
	 shift @$isa;
	 { no strict 'refs';
	   @{"$pkg\::ISA"}=@$isa; }

	 foreach my $s (@$isa) {
	    if (defined (my $super_constructor=UNIVERSAL::can($s, ".constructor"))) {
	       $super=$s;
	       ($cnt, $constructor)=$super_constructor->();
	       if (!$own_signature && defined (my $super_signature=UNIVERSAL::can($super, ".signature"))) {
		  ($signature, $min_arg, $max_arg, $trailing_list)=$super_signature->();
	       }
	       if (my $k=UNIVERSAL::can($s, ".keys")) {
	          $keyed_args=1;
		  %keys=%{$k->()};
	       }
	       $redefine=1;
	       if ($with_namespaces && namespaces::uses($super)) {
		  namespaces::using($pkg, $super);
	       }
	       last;
	    }
	 }

      } elsif ($_[0]->[0] eq 'new') {
	 $signature=(shift)->[1];
	 if ($signature !~ m'^ (\$*) (?: ;(\$+) | (%))? (\@)? $ 'x) {
	    croak "invalid constructor signature: '$signature'";
	 }
	 $own_signature=$signature;
	 $min_arg=length($1);
	 $check_arg= $min_arg>0 && "\@_ <= $min_arg";
	 $max_arg=$min_arg+length($2)+1;
	 $trailing_list=$4 && $max_arg;
	 if (defined $2) {
	    if (!$4) {
	       $check_arg .= ($min_arg>0 && " or ") ."\@_ > $max_arg";
	    }
	 } elsif ($3) {
	    $keyed_args=1;
	 }

      } else {
	 last;
      }
   }

   foreach my $field (@_) {
      my ($code, $name)=split //, (ref($field) ? $field->[0] : (undef($redefine), $field)), 2;
      if ($code !~ m'[$@%&]') {
         croak "unknown field type '$code'$name";
      }
      my $accessor=UNIVERSAL::can($pkg,$name);
      if (defined($redefine)) {
	 if (!defined($accessor) || ($redefine=get_field_index($accessor))<0) {
	    undef $redefine;	# new field or an occasionaly overwritten non-field method
	 }
      } elsif (get_field_index($accessor)>=0) {
	 croak "multiple definition of field $name";
      }
      my @aliases=split /\s*\|\s*/, $name;
      my ($kname, $get_kname, $get_kname_trailer);
      if ($keyed_args) {
	 if (@aliases>1) {
	    $kname='$kname';
	    $get_kname=<<"_#_#_#_";
do {
   my \$kname;
   foreach (qw(@aliases)) {
      if (exists \$kw{\$_}) {
	 \$kname=\$_;
	 last
      }
   }
   \$kname
_#_#_#_
            $get_kname_trailer=<<"_#_#_#_";
}
_#_#_#_
	 } else {
	    $kname="'$name'";
	    $get_kname="exists \$kw{$name}";
         }
      }
      my ($key_in_expr, $set_filter);
      my $deflt=$code eq '@' ? "[]" :
                $code eq '%' ? "{}" :
	        $code eq '&' ? "undef" :
                               "''";
      my $add_to_keys=$keyed_args;
      my $init=
         ref($field)
	 ? $field->[1] eq '##'
	   ? do {
	        undef $get_kname; $add_to_keys=-1;
		$deflt
	     } :
	   $field->[1] eq '@'
	   ? do {
	        if (defined($trailing_list)) {
		   undef $get_kname; $add_to_keys=-1;
		   $keyed_args
		   ? "\\\@trailing_list"
		   : "[ splice \@_, $max_arg ]"
		} else {
		   croak "no trailing list declared in the signature"
		}
	     } :
	   $code eq '&' && $field->[1] =~ /^->\s*(\w+)(?:\s*\|\|\s*(.+))?$/
	   ? do {
	        $add_to_keys=-1;
	        if ((my $super_index=get_field_index(UNIVERSAL::can($pkg,"$1"))) >= 0) {
		   if ($2) {
		      $set_filter=eval "$prologue; $2";
		      croak "syntax error compiling method fallback for $name: $@" if $@;
		   }
		   unless (exists &{$symtab->{original_object}}) {
		      define_function($symtab, "original_object", \&original_object);
		   }
		   $super_index;
	        } else {
		   croak "reference to an unknown field $1 in initialiser of $name";
	        }
	     }
	   : do {
	        my $expr=$field->[1];
	        if ($expr =~ s{(?: (?<=^) | (?<=\s)) \#(?:([\d+]) | (%)) (?= $ | \s)}
	                      { $2 ? $keyed_args ? ($key_in_expr=1, "$kname, #%") : croak("constructor has no keyword arguments")
			           : $1<$max_arg
				     ? ($add_to_keys=-1, "\$_[$1]")
				     : croak("constructor argument #$1 out of range") }egx) {
	           if ($key_in_expr) {
		      if ($#$field>=2) {
		         ($deflt=$expr) =~ s/\#%/$field->[2]/g;
		      }
		      $expr =~ s/\#%/delete \$kw{$kname}/g;
		      $expr = "$get_kname ? ($expr) : Struct::mark_as_default($deflt) $get_kname_trailer";
		   }
		   undef $get_kname;
	        }
	        if ($code eq '@') {
		   $expr =~ s/^ \s* \( (.*) \) \s* $/[$1]/x
		      or
		   $expr =~ s/^ \s* \@ .*/[$&]/x;
	        } elsif ($code eq '%') {
		   $expr =~ s/^ \s* \( (.*) \) \s* $/{$1}/x
		      or
		   $expr =~ s/^ \s* % .*/{$&}/x;
	        }
	        $expr
	     }
	 : $deflt;
      if ($get_kname) {
	 $init="$get_kname ? delete \$kw{$kname} : Struct::mark_as_default($init) $get_kname_trailer";
      }
      if ($add_to_keys>0) {
	 @keys{@aliases}=();
         $keys_changed=1;
      } elsif ($add_to_keys<0 && $redefine && $keyed_args) {
         delete @keys{@aliases};
         $keys_changed=1;
      }
      $set_filter ||= $key_in_expr && do {
	 my $expr=$field->[1];
	 $expr =~ s{(?: (?<=^) | (?<=\s)) \#% (?= $ | \s)}{\@_}x;
	 eval "$prologue; sub { $expr }"
	 or croak "syntax error compiling set-accessor for $name: $@";
      };
      if (defined($redefine)) {
	 if ($redefine) {
	    my $prev=$redefine-1;
	    $constructor =~ /\#\#\#<$prev>\n/s;
	    pos($constructor)=$+[0];
	 }
	 $constructor =~ s/\G .*? (?= ,\s*\#\#\#<$redefine>\n)/$init/xs;
         if ($set_filter) {
            $accessor=create_accessor($redefine, $code eq '&');
	    define_function($symtab, $_, $accessor) for @aliases;
	    ${$symtab->{$aliases[0]}}=$set_filter;
         }

      } else {
	 $constructor .= "$init, ###<$cnt>\n";
	 $accessor=create_accessor($cnt, $code eq '&');
	 define_function($symtab, $_, $accessor) for @aliases;
	 if ($set_filter) {
	    ${$symtab->{$aliases[0]}}=$set_filter;
	 }
	 ++$cnt;
      }
   }

   if (@_ || $own_signature) {
      my $new_text= <<"_#_0_#_";
$prologue;
sub {
_#_0_#_
      if ($keyed_args) {
	 $new_text .= <<"_#_1_#_";
   my %kw;
_#_1_#_
         if (defined($trailing_list)) {
            $new_text .= <<"_#_2_#_";
   my \@trailing_list;
   for (my \$i=$max_arg; \$i<=\$#_; ) {
      if (Poly::is_hash(\$_[\$i])) {
	 push %kw, %{\$_[\$i++]};
      } elsif (!ref(\$_[\$i]) && exists \$keys{\$_[\$i]}) {
	 \$kw{\$_[\$i]}=\$_[\$i+1];
	 \$i+=2;
      } else {
         \@trailing_list=splice \@_, \$i;
         last;
      }
   }
_#_2_#_
         } else {
            $new_text .= <<"_#_3_#_";
   for (my \$i=$max_arg; \$i<=\$#_; ) {
      if (Poly::is_hash(\$_[\$i])) {
	 push %kw, %{\$_[\$i++]};
      } else {
	 \$kw{\$_[\$i]}=\$_[\$i+1];
	 \$i+=2;
      }
   }
_#_3_#_
         }
      }
      if ($check_arg) {
	 $new_text .= <<"_#_4_#_";
   if ($check_arg) {
      Poly::croak( "usage: new \$_[0] (" . '$signature' . ")" );
   }
_#_4_#_
      }
      if ($keyed_args) {
	 $new_text .= <<"_#_5_#_";
   my \$self=Poly::inherit_class( Struct::start_compile_constructor(), [
$constructor
   ], shift);
   if (keys %kw) {
      Poly::croak( ref(\$self), "::new - unknown keywords: ", join(", ", keys %kw) );
   }
   \$self
_#_5_#_
      } else {
	 $new_text .= <<"_#_6_#_";
   Poly::inherit_class([
$constructor
   ], shift);
_#_6_#_
      }
      $new_text .= <<"_#_9_#_";
}
_#_9_#_
      my $_new=eval $new_text;
      if ($@) {
	 my @new_lines=(undef, split /(?:\#\#\#<\d+>)?\n/, $new_text);	# leading undef makes the line numbers = array index
	 $@ =~ s/at \(eval \d+\) line (\d+)/near line $1: '$new_lines[$1]'/g;
	 croak "syntax error building $pkg constructor: $@";
      }
      define_function($symtab, "__new", $_new);
   } elsif (!$super) {
      croak "no own fields and no Struct-based super class specified";
   }

   define_function($symtab, ".defined", sub { "$file line $line" });
   define_function($symtab, ".constructor", sub { ($cnt, $constructor) });
   define_function($symtab, "sizeof", sub { $cnt });
   define_function($symtab, ".signature", sub { ($signature, $min_arg, $max_arg, $trailing_list) }) if $own_signature;
   if ($keys_changed) {
      define_function($symtab, ".keys", sub { \%keys });
    }
   define_function($symtab, "_new", \&_new);
   if (!$super || UNIVERSAL::can($super, "new")==UNIVERSAL::can($super, "_new")) {
      define_function($symtab, "new", \&_new);
   } elsif ($with_namespaces) {
      # predeclare for the sake of cleaner syntax in the package's code
      no strict 'refs';
      *{"$pkg\::new"}=UNIVERSAL::can($super, "new");
   }
}

sub _new { &{UNIVERSAL::can($_[0],"__new")} }

1;
