#  Copyright (c) 1997-2010
#  Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Darmstadt, Germany)
#  http://www.polymake.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: regex.pl 9615 2010-04-06 23:39:18Z gawrilow $

use namespaces;
use re 'eval';
package Polymake;

# an identifier (alphanumeric, first character not a digit)
declare $id_re=qr{(?> (?!\d)\w+ )}x;

# a list of identifiers (separated by commas)
declare $ids_re=qr{(?> $id_re (?: \s*,\s* $id_re)* )}xo;

# hierarchical identifier (identifiers connected with dots)
declare $hier_id_re=qr{(?> $id_re (?: \. $id_re)* )}xo;

# a list of hierarchical identifiers (separated by commas)
declare $hier_ids_re=qr{(?> $hier_id_re (?: \s*,\s* $hier_id_re)* )}xo;

# a list of hierarchical identifiers (separated by bars)
declare $hier_id_alt_re=qr{(?> $hier_id_re (?: \s*\|\s* $hier_id_re)* )}xo;

# a list of alternatives (separated by commas)
declare $hier_id_alts_re=qr{(?> $hier_id_alt_re (?: \s*,\s* $hier_id_alt_re)* )}xo;

# a lone identifier
declare $id_only_re=qr{ ($id_re) \s*$ }xo;

# fully qualified name
declare $qual_id_re=qr{(?> $id_re (?: :: $id_re)* )}xo;

# a list of fully qualified names
declare $qual_ids_re=qr{(?> $qual_id_re (?: \s*,\s* $qual_id_re)* )}xo;

# unqualified name
declare $unqual_id_re=qr{(?<!::) (?<!\w) $id_re (?! :: )}xo;

declare $balanced_re;
declare $confined_re=qr{ \( (??{ $balanced_re }) \) |
                         \[ (??{ $balanced_re }) \] |
                         \{ (??{ $balanced_re }) \} |
			  < (??{ $balanced_re })  > |
		          ' (??{ $balanced_re })  ' |
		          " (??{ $balanced_re })  " }xo;

my $non_delims=qr{ [^()\[\]{}<>'"\#]+ | (?<=\\)(?<!\\\\) [()\[\]{}<>"'\#] | (?<=[-=])(?<!<=) > }x;

$balanced_re=qr{ (?> (?:$non_delims)* ) (?: $confined_re (?> (?:$non_delims)* ) )* }xo;

# allow some unmatched open braces
declare $open_balanced_re=qr{ (?: (?> (?:$non_delims)* ) (?: \( (?: (??{ $balanced_re }) \) )? |
						             \[ (?: (??{ $balanced_re }) \] )? |
						             \{ (?: (??{ $balanced_re }) \} )? |
						              < (?: (??{ $balanced_re })  > )? |
			                                     $ ) )* }xo;

# variable assignment as full statement
declare $assignment_re=qr{ ([\$\@%] $qual_id_re) \s*= (?: [^\#\n]+; | .*\n (?: ^.*\n)*? ^ [^\#\n]+; ) }xom;

# an expression in a list
declare $expression_re=qr{ (?: (?(?=['"\(\[\{]) $confined_re | (?=.)) (?> [^,'"()\[\]{}]* ) )+ }xo;

# property type, possibly parameterized;  extended form allows function call-like expressions
declare ($type_re, $extd_type_re);

# a list of types (separated by commas)
declare $types_re     =qr{(?> (??{ $type_re })      (?: \s*,\s* (??{ $type_re }))*      )}xo;
declare $extd_types_re=qr{(?> (??{ $extd_type_re }) (?: \s*,\s* (??{ $extd_type_re }))* )}xo;

$type_re=     qr{ $qual_id_re (?: \s*<\s* $types_re \s*> )? }xo;
$extd_type_re=qr{ $qual_id_re (?: \s*<\s* $extd_types_re \s*> | \s*\( $balanced_re \) )? }xo;

# a type expression qualifying some following name
# (can't simply write $type_re :: $hier_id_re here because of the greedy nature of the former)
declare $type_qual_re=qr{ $id_re (?: :: $id_re)* (?: \s*<\s* $types_re \s*>\s* )? (?= ::) }xo;

# type with field name prepended
declare $field_re  =qr{ $id_re \s*=>\s* (??{ $type_re }) }xo;
declare $fields_re =qr{(?> $field_re  (?: \s*,\s* $field_re)* )}xo;

# base class for a property type: may contain field names
declare $super_type_re=qr{ $qual_id_re (?: \s*<\s* (?(?= $id_re \s*=>) $fields_re | $types_re) \s*> )? }xo;

# a type parameter in a declaration
declare $type_param_re=     qr{ $id_re (?: \s*=\s* $type_re )? (?: \s*\[ $balanced_re \] )? }xo;
declare $extd_type_param_re=qr{ $id_re (?: \s*=\s* $extd_type_re )? }xo;

# a list of type parameters
declare $type_params_re     =qr{(?> $type_param_re      (?: \s*,\s* $type_param_re)* )}xo;
declare $extd_type_params_re=qr{(?> $extd_type_param_re (?: \s*,\s* $extd_type_param_re)* )}xo;

# function declaration with optional signature
declare $sub_re=qr{ ($id_re) \b (?: \s*\( ($balanced_re) \) )? }xo;

# function declaration with optional template parameters and signature
declare $extd_sub_re=qr{ ($id_re) (?=[<(:;\s]) (?: \s*< ($extd_type_params_re) > )? (?: \s*\( ($balanced_re) \) )? }xo;

# overloaded function declaration with optional labels
declare $labeled_sub_re=qr{ (?:($hier_ids_re)\s*:\s*)? $extd_sub_re }xo;

# rule input clause
declare $rule_input_re=qr{ $hier_id_re (?: \s*[|,]\s* $hier_id_re )* }xo;

# filename (directory part stripped)
declare $filename_re=qr{ ([^/]+) $ }x;

# directory name (file part stripped)
declare $directory_re=qr{ ^(.*) / [^/]+$ }x;

# an empty line
declare $empty_line_re=qr{^ [ \t]* \n}xm;

# an empty line or separator (a line of hashes)
declare $empty_or_separator_line=qr{^ (?: [ \t]* | \#{2,} ) \n}xm;

# an empty line with possible comments
declare $nonsignificant_line_re=qr{^ [ \t]* (?:\#.*)? \n}xm;

# a line with some contents (like perl code)
declare $significant_line_re=qr{^ [ \t]* (?! $ | \#) }xm;

sub translate_type {
   $_[0] =~ tr/<>/()/;
   substr($_[0], rindex($_[0],";")+1) =~ s/($id_re)(?!\s*(?:[-:[]|=>))/$1->type/go;
}

sub report_type_error {
   if ($@ =~ /^Undefined subroutine &?(?:$id_re\::)*($id_re) called/o ||
       $@ =~ /^Bareword "($id_re)" not allowed/o ||
       $@ =~ /Package "($id_re)" does not exist/o) {
      croak( "Unknown type '$1'" );
   } elsif ($@ =~ s/ at \(eval \d+\).*\n//) {
      croak( "Invalid type expression '$_[0]': $@" );
   } else {
      die $@;
   }
}

sub eval_type_expr {
   my $expr=shift;
   if (is_string($$expr)) {
      translate_type($$expr);
      $$expr=eval($$expr) || report_type_error($$expr);
   } else {
      $$expr;
   }
}

1;
