#  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 7540 2006-12-21 21:04:18Z gawrilow $

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 $constructor_deferred="";
   my $merger="";
   my ($signature, $own_signature, $check_arg, $min_arg, $max_arg, $keyed_args, %keys, $keys_changed, $trailing_list,
       $super, $super_symtab, $redefine, $merge_seen);
   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, $constructor_deferred, $merger)=$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);
	       }
	       $super_symtab=get_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);
      if ($keyed_args) {
	 if (@aliases>1) {
	    $kname='$kname';
	    $get_kname=<<"_#_#_#_";
do {
   undef \$kname;
   exists \$kw{\$_} and (\$kname=\$_, last) for (qw(@aliases))
}
_#_#_#_
	 } else {
	    $kname="'$name'";
	    $get_kname="exists \$kw{$name}";
         }
      }
      my ($key_in_expr, $set_filter, $set_filter_is_method, $init_deferred, $merge_expr);
      my $deflt=$code eq '@' ? "[]" :
                $code eq '%' ? "{}" :
	        $code eq '&' ? "undef" :
                               "''";
      my $add_to_keys=$keyed_args;
      my $init=
         ref($field)
	 ? $field->[1] eq '##'
	   ? do {
	        croak "unexpected options for the uninitialized field $name" if $#$field>1;
	        undef $get_kname; $add_to_keys=-1;
		$deflt
	     } :
	   $field->[1] eq '@'
	   ? do {
	        if (defined($trailing_list)) {
		   croak "unexpected options for the trailer-initialized field $name" if $#$field>1;
		   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 {
		croak "unexpected options for the method field $name" if $#$field>1;
	        $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 the field $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 initializer of the field $name";
	        }
	     }
	   : do {
		croak "odd options list for the field $name" if !($#$field%2);
	        my $expr=$field->[1];
		my %options=splice @$field, 2;
		$init_deferred=$set_filter_is_method= $expr =~ /(?<!\\)\$this\b/;
	        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 (defined (my $default_arg=delete $options{default})) {
			 $init_deferred ||= $default_arg =~ /(?<!\\)\$this\b/;
		         ($deflt=$expr) =~ s/\#%/$default_arg/g;
		      }
		      $expr =~ s/\#%/delete \$kw{$kname}/g;
		      $expr = "$get_kname ? ($expr) : Struct::mark_as_default($deflt)";
		   }
		   if (defined (my $merge_arg=delete $options{merge})) {
		      $merge_arg =~ s/\#%/$kname, delete \$kw{$kname}/;
		      $merge_expr="$get_kname and $merge_arg";
		      $merge_seen=1;
		   }
		   undef $get_kname;
	        }
		if (keys %options) {
		   croak "unknown or unexpected option(s) ", join(", ", keys %options), " for the field $name";
		}

	        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)";
      }
      if ($init_deferred) {
	 $init_deferred=$init;
	 $init="undef";
      }
      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];
	 if ($expr =~ /^\s* (?: \$this\s*->\s* )? ((?!\d)\w+) \(\s* \#% \s*\) \s*$/x) {
	    $1
	 } else {
	    my $mys= ($set_filter_is_method &&= " : method") && 'my $this=shift; ';
	    $expr =~ s{(?: (?<=^) | (?<=[\s,(])) \#% (?= $ | [\s,)])}{\@_}x;
	    eval "$prologue; sub$set_filter_is_method { $mys$expr }"
	    or croak "syntax error compiling access filter for the field $name: $@";
	 }
      };
      if (defined($redefine)) {
	 use re 'eval';

	 if ($redefine) {
	    my $prev=$redefine-1;
	    $constructor =~ /\#\#\#<$prev>\n/s;
	    pos($constructor)=$+[0];
	 }
	 $constructor =~ s/\G .*? (?= ,\s*\#\#\#<$redefine>\n)/$init/xs;

	 if ($init_deferred) {
	    $constructor_deferred =~ s{(^ | \#\#\#<(\d+)>\n) (?(?{ $2!=$redefine }) .*? | (?!.)) (?= ;\s*\#\#\#<$redefine>\n)}
				      {$1\$this->[$redefine]=$init_deferred}xs
	       or
	    $constructor_deferred .= "\$this->[$redefine]=$init_deferred; ###<$redefine>\n";
	 } elsif ($constructor_deferred) {
	    $constructor_deferred =~ s/(^ | \#\#\#<(\d+)>\n) (?(?{ $2!=$redefine }) .*? | (?!.)) ;\s*\#\#\#<$redefine>\n/$1/xs;
	 }
         if ($set_filter || defined(${$super_symtab->{$aliases[0]}})) {
            $accessor=create_accessor($redefine, $code eq '&');
	    define_function($symtab, $_, $accessor) for @aliases;
	    ${$symtab->{$aliases[0]}}=$set_filter;
         }
	 if ($merge_expr) {
	    $merger =~ s/(^ | \#\#\#<(\d+)>\n) (?(?{ $2!=$redefine }) .*? | (?!.)) (?= ;\s*\#\#\#<$redefine>\n)/$1$merge_expr/xs
	       or
	    $merger .= "$merge_expr; ###<$redefine>\n";
	 }

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

   if (@_ || $own_signature) {
      my $new_text= <<"_#_0_#_";
$prologue;
sub {
_#_0_#_
      if ($keyed_args) {
	 $new_text .= <<"_#_1_#_";
   my (%kw,\$kname);
_#_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 \$this=Poly::inherit_class( Struct::start_compile_constructor(), [
$constructor
   ], shift);
$constructor_deferred
   if (keys %kw) {
      Poly::croak( ref(\$this), "::new - unknown keywords: ", join(", ", keys %kw) );
   }
   \$this
_#_5_#_
      } else {
	 $new_text .= <<"_#_8_#_";
   Poly::inherit_class([
$constructor
   ], shift);
_#_8_#_
      }
      $new_text .= <<"_#_9_#_";
}
_#_9_#_
      my $_new=eval $new_text;
      if ($@) {
	 my @lines=(undef, split /(?:\#\#\#<\d+>)?\n/, $new_text);	# leading undef makes the line numbers = array index
	 $@ =~ s/at \(eval \d+\) line (\d+)/near line $1: '$lines[$1]'/g;
	 croak "syntax error in $pkg\::new: $@";
      }
      define_function($symtab, "__new", $_new);

      if ($merge_seen) {
	 my $merge_text=<<"_#_#_#_";
$prologue;
sub {
   my (\$this, %kw)=\@_;
   my \$kname;
$merger
   if (keys %kw) {
      Poly::croak( ref(\$this), "::merge - unknown or non-mergeable field(s): ", join(", ", keys %kw) );
   }
   \$this
}
_#_#_#_
	 my $_merge=eval $merge_text;
	 if ($@) {
	    my @lines=(undef, split /(?:\#\#\#<\d+>)?\n/, $new_text);
	    $@ =~ s/at \(eval \d+\) line (\d+)/near line $1: '$lines[$1]'/g;
	    croak "syntax error in $pkg\::merge: $@";
	 }
	 define_function($symtab, "merge", $_merge);
      }
   } 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, $constructor_deferred, $merger) });
   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;