# ==========================================
# Copyright (C) 2004 kyle dawkins
# kyle-at-centralparksoftware.com
# ObjectivePerl is free software; you can
# redistribute and/or modify it under the 
# same terms as perl itself.
# ==========================================

package ObjectivePerl::Parser;
use strict;
use Carp;

my $OBJP_START = "~[";
my $OBJP_START_MATCH_FOR_END = "[";
my $OBJP_END = "]";
my $OBJP_SUPER = 'super';

#use IF::Log;
use Text::Balanced qw(extract_codeblock);

my $_parser;

sub new {
	my $className = shift;
	return $_parser if $_parser;
	my $self = {
			_content => [],
			_currentClass => "",
			_classes => {},
		};
	bless $self, $className;
	$_parser = $self;
	return $self;
}

sub initWithFile {
	my $self = shift;
	my $fullPath = shift;

	$self->setFullPath($fullPath);
	$self->setSource(contentsOfFileAtPath($fullPath));
	$self->parse();
}

sub initWithString {
	my $self = shift;
	my $string = shift;

#	IF::Log::debug("Parser re-initialised with string ".substr($string, 0, 30)."...");
	$self->setFullPath();
	$self->setSource($string);
	$self->setContent([]);
	$self->parse();
#$self->dump();
}

sub setFullPath {
	my $self = shift;
	$self->{_fullPath} = shift;
}

sub fullPath {
	my $self = shift;
	return $self->{_fullPath};
}

sub content {
	my $self = shift;
	return $self->{_content};
}

sub setContent {
	my $self = shift;
	$self->{_content} = shift;
}

sub contentElementAtIndex {
	my $self = shift;
	my $index = shift;
	my $content = $self->content();
	return $content->[$index];
}

sub contentElementsInRange {
	my $self = shift;
	my $start = shift;
	my $end = shift;
	my $content = $self->content();
	return [$content->[$start..$end]];
}

sub contentElementCount {
	my $self = shift;
	return scalar @{$self->content()};
}

sub source {
	my $self = shift;
	return $self->{_source};
}

sub setSource {
	my $self = shift;
	$self->{_source} = shift;
}

# This is a trick to allow the perl parser
# to take over again and import and parse use'd
# classes before continuing with this class
sub shouldSuspendParsing {
	my $self = shift;
	foreach my $contentElement (@{$self->content()}) {
		return 1 if ($contentElement =~ /^no ObjectivePerl;$/m);
	}
	return 0;
}

sub parse {
	my $self = shift;
	$self->setContent([$self->source()]);
	$self->parseImplementationDetails();
	if ($self->shouldSuspendParsing()) {
		# Suspending parsing to allow import of parent classes
		return;
	}
	$self->breakIntoPackages();
	$self->parseMethodDefinitions();
	$self->parseMethodsForInstanceVariables();
	$self->extractMessages();
	$self->translateMessages();
#$self->dump();
}

sub breakIntoPackages {
	my $self = shift;
	my $content = $self->content();
	my $splitContent = [];
	foreach my $contentElement (@$content) {
		while (1) {
			if ($contentElement =~ /^\s*(package\s+[A-Za-z0-9_:]+\s*;)/m) {
				my $packageDeclaration = $1;
				$packageDeclaration =~ /package\s+([A-Za-z0-9_:]+)/;
				my $packageName = $1;
				unless ($self->{_classes}->{$packageName}) {
					$self->{_classes}->{$packageName} = { methods => {} };
				}
				my $quotedPackageDeclaration = quotemeta($packageDeclaration);
				my ($beforePackage, $afterPackage) = split(/$quotedPackageDeclaration/, $contentElement, 2);
				my $packageVariableDeclarations = "\n\n\$".$self->{_currentClass}."::".$OBJP_SUPER." = '_SUPER';\n";
				push (@$splitContent, $beforePackage, $packageDeclaration, $packageVariableDeclarations);
				$contentElement = $afterPackage;
			} else {
				push (@$splitContent, $contentElement);
				last;
			}
		}
	}
	$self->setContent($splitContent);
}

sub parseImplementationDetails {
	my $self = shift;
	foreach my $contentElement (@{$self->content()}) {
		while ($contentElement =~ /^(\@(implementation|protocol) ([A-Za-z0-9_\:]+)( :\s*([A-Za-z0-9_\:]+))?\s*(\<\s*((([A-Za-z0-9_\:]+),?\s*)*)\s*\>)?\s*(($|\{(\s|$)*)(\s*(\@(private|protected):\s*)?\$[a-zA-Z0-9_]+\s*[;,]\s*($)?)*\})?)/mo) {
			#print "1: $1\n2: $2\n3: $3\n4: $4\n5: $5\n6: $6\n7: $7\n8: $8\n9: $9\n10: $10\n";
			my $substituteRegExp = quotemeta($1);
			my $className = $3;
			my $parentClassName = $5;
			my $protocolList = $7 || "";
			my $protocols = [split(/[, ]+/, $protocolList)];
			my $instanceDeclarations = $10;
# (($|\{\s*$)(\s*\$[a-zA-Z0-9_]+\s*[;,]\s*($)?)*\})
			my $newClassDefinition = $self->classDefinitionFromClassAndParentClassConformingToProtocols($className, $parentClassName, $protocols);
			my $ivars = instanceVariablesFromInstanceDeclarations($10);

			$self->{_classes}->{$className} = {
					parent => $parentClassName,
					protocols => $protocols,
					ivars => $ivars,
			};
			my $ivarDeclaration = "use ObjectivePerl::InstanceVariable;\n";
			$ivarDeclaration .= "\$".$self->{_currentClass}."::objp_ivs = {\n";
			foreach my $level qw(private protected) {
				next unless ($ivars->{$level});
				$ivarDeclaration .= "\t$level => [qw(".join(" ", @{$ivars->{$level}}).")],\n";
			}
			$ivarDeclaration .= "};\n";
			$newClassDefinition = $newClassDefinition.$ivarDeclaration;
			$contentElement =~ s/$substituteRegExp/$newClassDefinition/m;
		}
		$contentElement =~ s/^\@end/1;package main;\n/mg;
	}
#$self->dump();
}

sub parseMethodDefinitions {
	my $self = shift;
	foreach my $contentElement (@{$self->content()}) {
		next if (ref $contentElement eq 'ARRAY');
		#IF::Log::debug("Check element for methods: $contentElement");
		if ($contentElement =~ /^package ([A-Za-z0-9_:]+);/m) {
			$self->{_currentClass} = $1;
		}
		while ($contentElement =~ /^([\+\-]) ([a-zA-Z0-9_]+[^\{]*{)/m) {
			my $methodType = "INSTANCE";
			my $methodLine = quotemeta("$1 $2");
			my $methodDeclaration = $2;
			if ($1 eq "+") {
				$methodType = "STATIC";
			}

			my $newMethodDefinition = methodDefinitionFromMethodTypeAndDeclaration(
										$methodType, $methodDeclaration);
			if ($self->{_classes}->{$self->{_currentClass}}->{methods}->{$newMethodDefinition->{signature}}) {
				#IF::Log::dump($self->{_classes}->{$self->{_currentClass}}->{methods});
				croak("Warning, redefinition of method shown here: ".$newMethodDefinition->{signature}." in class ".$self->{_currentClass});
			}
			$self->{_classes}->{$self->{_currentClass}}->{methods}->{$newMethodDefinition->{signature}} = $newMethodDefinition;
			
			my $newMethodLine = "sub ".$newMethodDefinition->{signature}." {\n";
			$newMethodLine .= "\tmy (".join(", ", '$objp_self', @{$newMethodDefinition->{arguments}}).") = \@_;\n";
			if ($newMethodDefinition->{type} eq "INSTANCE") {
				$newMethodLine .= "\tmy \$self = \$objp_self;\n";
			} else {
				$newMethodLine .= "\tmy \$className = \$objp_self;\n";
			}
			$newMethodLine .= "#OPIV\n";
			$contentElement =~ s/$methodLine/$newMethodLine/g;
		}
	}
}

sub parseMethodsForInstanceVariables {
	my $self = shift;
	foreach my $contentElement (@{$self->content()}) {
		next if (ref $contentElement eq 'ARRAY');
		if ($contentElement =~ /^package ([A-Za-z0-9_:]+);/m) {
			$self->{_currentClass} = $1;
		}
		my $foundMethods = [];
		while ($contentElement =~ /^\s*sub ([a-zA-Z0-9_]+)([^\{]|$)*{/mgo) {
			push (@$foundMethods, $1);
		}

		foreach my $methodName (@$foundMethods) {
			my $methodDefinition = $self->{_classes}->{$self->{_currentClass}}->{methods}->{$methodName};
			my $isInstanceMethod;
			if ($methodDefinition) {
				#IF::Log::dump($methodDefinition);
				$isInstanceMethod = ($methodDefinition->{type} eq "INSTANCE");
			}
			my ($beforeSub, $afterSub) = split(/^sub $methodName\s+/sm, $contentElement, 2);
			my @stuff = extract_codeblock($afterSub, '{}');
			my $methodBlock = $stuff[0];
			
			if ($methodBlock) {
				my $originalCode = quotemeta($methodBlock);
				
				# look through the method for ivar uses
				# also here is where we *would* check for visibility rules.  Right now,
				# all ivars are considered "protected"
				
				my $ivars = {};
				my $currentClass = $self->{_currentClass};
				my $visitedClasses = { $currentClass => 1 };
				foreach my $level qw(private protected) {
					next unless $self->{_classes}->{$currentClass}->{ivars}->{$level};
					$ivars->{$level} = [] unless $ivars->{$level};
					push (@{$ivars->{$level}}, @{$self->{_classes}->{$currentClass}->{ivars}->{$level}});
				}
				while ($currentClass = $self->{_classes}->{$currentClass}->{parent}) {
					last if ($visitedClasses->{$currentClass});
					foreach my $level qw(protected) { # eventually we'll add public but for now no
						next unless $self->{_classes}->{$currentClass}->{ivars}->{$level};
						$ivars->{$level} = [] unless $ivars->{$level};
						push (@{$ivars->{$level}}, @{$self->{_classes}->{$currentClass}->{ivars}->{$level}});
					}
					$visitedClasses->{$currentClass}++;
				}
				
				my $usedIvars = [];
				foreach my $level qw(private protected) {
					foreach my $ivar (@{$ivars->{$level}}) {
						my $quotedIvar = quotemeta($ivar);
						if ($methodBlock =~ /$quotedIvar/) {
							push (@$usedIvars, $ivar);
						}
						my $arguments = $methodDefinition? $methodDefinition->{arguments} : [];
						foreach my $argument (@$arguments) {
							if ($ivar eq $argument) {
								croak "Can't have argument with the same name as instance variable $ivar\nin method $methodName";
							}
						}
					}
				}

				my $ivarImports = "";
				if (@$usedIvars && $isInstanceMethod) {
					foreach my $ivar (@$usedIvars) {
						(my $hashKey = $ivar) =~ s/\$//;

						$ivarImports .= qq(\tmy $ivar; tie $ivar, "ObjectivePerl::InstanceVariable", \$self, "$hashKey";\n);
						# there *has* to be a way to do this with typeglobs:
						#(my $glob = $ivar) =~ s/\$/\*/;
						#$ivarImports .= qq(\t$glob = \\\${\$objp_self->{_v}->{$hashKey}};\n);
					}
				}
			
				$methodBlock =~ s/^#OPIV/$ivarImports/gsm;
				$contentElement =~ s/$originalCode/$methodBlock/;
			}
		}
	}
}

sub translateMessages {
	my $self = shift;
	my $content = $self->content();
	foreach my $contentElement (@$content) {
		next unless ref $contentElement eq 'ARRAY';
		$contentElement = messageInvocationForContentElements($contentElement);
		#IF::Log::debug($contentElement);
	}
}

sub messageInvocationForContentElements {
	my $contentElements = shift;

	my $message;
	foreach my $contentElement (@$contentElements) {
		if (ref $contentElement eq 'ARRAY') {
			$contentElement = messageInvocationForContentElements($contentElement);
		}
		$message .= $contentElement;
	}
	
	my $receiver = extractDelimitedChunkTerminatedBy($message, " ");
	my $quotedReceiver = quotemeta($receiver);
	$message =~ s/$quotedReceiver\s*//;

	my $messageName = extractDelimitedChunkTerminatedBy($message, ":");
	my $quotedMessageName = quotemeta($messageName);
	$message =~ s/$quotedMessageName[:]?\s*//;

	my $selectorArray = "";
	my $selectors = [];
	if ($message ne '') {
		# looks like we have selectors

		my $argument = extractDelimitedChunkTerminatedBy($message, " ");
		push (@$selectors, { key => "$messageName", value => $argument });
		my $quotedArgument = quotemeta($argument);
		$message =~ s/$quotedArgument\s*//;
		while ($message ne '') {
			#IF::Log::debug("MESSAGE: $message");
			my $selector = extractDelimitedChunkTerminatedBy($message, ":");
			my $quotedSelector = quotemeta($selector);
			$message =~ s/$quotedSelector[:]\s*//;
			my $argument = extractDelimitedChunkTerminatedBy($message, " ");
			if ($selector eq "") {
				$selector = "_";
			}
			push (@$selectors, { key => "$selector", value => $argument });
			my $quotedArgument = quotemeta($argument);
			$message =~ s/$quotedArgument\s*//;
		}

		$selectorArray = "[\n";
		foreach my $selector (@$selectors) {
			$selector->{key} = quoteIfNecessary($selector->{key});
			$selectorArray .= "\t{ key => ".$selector->{key}.", value => ".$selector->{value}." },\n";
		}
		$selectorArray .= "]";
	}

	if ($receiver eq '$'.$OBJP_SUPER) {
		if ($messageName =~ /^[A-Za-z0-9_]+$/o) {
			my $methodName = ObjectivePerl::Runtime::messageSignatureFromMessageAndSelectors(
															  $messageName, $selectors);
			return '$objp_self->SUPER::'.$methodName.'('.join(",", map {$_->{value}} @$selectors).')';
		} else {
			# we need to use eval() to figure this one out...
			croak "Can't call super with dynamic message name";
		}
	}
	$messageName = quoteIfNecessary($messageName);
	$receiver = quoteIfNecessary($receiver);
	return "ObjectivePerl::Runtime->ObjpMsgSend($receiver, $messageName, $selectorArray)";
}

sub quoteIfNecessary {
	my $string = shift;
	if ($string =~ /^[A-Za-z0-9_i:]+$/) {
		$string = '"'.$string.'"';
	}
	return $string;
}

sub extractMessages {
	my $self = shift;
	$self->setContent(extractMessagesFromSource(join("", @{$self->content()})));
}

sub extractMessagesFromSource {
	my $source = shift;
	my $content = [];
	#IF::Log::debug("Extracting messages from $source");
	my $start = quotemeta($OBJP_START);
	my $end = quotemeta($OBJP_END);
	while ($source =~ /$start/i) {
		(my $beforeTag, my $afterTag) = split(/$start/, $source, 2);
		push (@$content, $beforeTag) unless $beforeTag eq "";
		my ($beforeEnd, $afterEnd) = splitSourceOnMessageEnd($afterTag);
		if ($beforeEnd =~ / /) {
			push (@$content, extractMessagesFromSource($beforeEnd));
		} else {
			push (@$content, $OBJP_START.$beforeEnd.$OBJP_END);
		}
		$source = $afterEnd;
	}
	push (@$content, $source);
	return $content;
}

sub dump {
	my $self = shift;
	my @lines = split(/\n/, join("", @{$self->content()}));
	my $lineNumber = 1;
	foreach my $line (@lines) {
		print sprintf("%03d: %s\n", $lineNumber++, $line);
	}
}

# static methods:

sub splitSourceOnMessageEnd {
	my $source = shift;
	my $start = quotemeta($OBJP_START);
	my $startMatchForEnd = "$start|".quotemeta($OBJP_START_MATCH_FOR_END);
	my $end = quotemeta($OBJP_END);
	my $startSource = "";
	my $tagDepth = 1;
	while (1) {
		$source =~ /($startMatchForEnd)/;
		my $startingMatch = $1;
		my @lookingForStart = split(/$startMatchForEnd/i, $source, 2);
		my @lookingForEnd = split(/$end/i, $source, 2);

		if ($#lookingForStart == 0 && $#lookingForEnd == 0) {
			croak (">>> Error parsing objp no matching ".$OBJP_END);
			return (undef, undef);
		}

		if (length($lookingForEnd[0]) < length($lookingForStart[0])) {
			$tagDepth -= 1;
			$source = $lookingForEnd[1];
			$startSource .= $lookingForEnd[0];
			if ($tagDepth > 0) {
				$startSource .= $OBJP_END;
			}
		} else {
			$tagDepth += 1;
			$source = $lookingForStart[1];
			$startSource .= $lookingForStart[0].$startingMatch;
		}

		if ($tagDepth <= 0) {
			return ($startSource, $source);
		}
	}
}

sub contentsOfFileAtPath {
	my $fullPathToFile = shift;
	
	if (open (FILE, $fullPathToFile)) {
		my $contents = join("", <FILE>);
		close (FILE);
		return $contents;
	} else {
		croak("Error opening $fullPathToFile");
		return;
	}
}

sub methodDefinitionFromMethodTypeAndDeclaration {
	my $type = shift;
	my $declaration = shift;
	
	my $declarationParts = [];
	my $arguments = [];
	my $methodDefinition = { type => $type };

	while ($declaration =~ /^([a-zA-Z0-9_]*)(:|\s|$)/) {
		my $part = $1;
		my $end = $2;

		push (@$declarationParts, $part);
		$declaration =~ s/^[a-zA-Z0-9_]*:?\s*//g;
		last unless ($end eq ":");

		$declaration =~ s/^\s*(\$[a-zA-Z0-9_]+)\s*//g;
		push (@$arguments, $1);
	}

	$methodDefinition->{selectors} = $declarationParts;
	$methodDefinition->{arguments} = $arguments;
	$methodDefinition->{signature} = join("_", @$declarationParts);
	return $methodDefinition;
}

sub classDefinitionFromClassAndParentClassConformingToProtocols {
	my ($self, $className, $parentClassName, $protocols) = @_;

	my $definition = "package $className;\n";
	$definition .= "use strict;\nuse vars qw(\@ISA \$".$OBJP_SUPER.");\nuse ObjectivePerl::Object;\n";
	my @isa = ();
	if ($parentClassName) {
		unless ($self->{_classes}->{$parentClassName}) {
			$definition .= "no ObjectivePerl;\n";
			$definition .= "use $parentClassName;\n";
		}
		#eval "use $parentClassName;"; # huh?!
		push (@isa, $parentClassName);
	}
	foreach my $protocol (@$protocols) {
		push (@isa, $protocol);
		$definition .= "use $protocol;\n";
	}
	if ($parentClassName && !$self->{_classes}->{$parentClassName}) {
		$definition .= "use ObjectivePerl class => '$className';\npackage $className;\n";
	}
	#$definition .= "package $className;\n"; # just to re-set the parser to the right package
	# add our own root entity class to the @isa tree:
	push (@isa, "ObjectivePerl::Object");
	$definition .= "\@ISA = qw(".join(" ", @isa).");\n\n";
	return $definition;
}

sub instanceVariablesFromInstanceDeclarations {
	my $instanceDeclarations = shift || "";
	my $instanceVariables = {};

	# split into visibility levels first
	my @parts = split(/\@/, $instanceDeclarations);
	my $visibilitySections = {};
	foreach my $part (@parts) {
		unless ($part =~ /^(private|protected)(.*)$/mso) {
			push (@{$visibilitySections->{protected}}, $part);
			next;
		}
		push (@{$visibilitySections->{$1}}, $2);
	}
	
	foreach my $level (keys %$visibilitySections) {
		foreach my $part (@{$visibilitySections->{$level}}) {
			while ($part =~ /(\$[A-Za-z0-9_]+)/g) {
				push (@{$instanceVariables->{$level}}, $1);
			}
		}
	}
	#IF::Log::dump($instanceVariables);
	return $instanceVariables;
}

# LAME:  there must be a better way
sub extractDelimitedChunkTerminatedBy {
	my $chunk = shift;
	my $terminator = shift;
	my $extracted = "";
	my $balanced = {};
	my $isQuoting = 0;
	my $outerQuoteChar = '';

	my @chars = split(//, $chunk);
	for (my $i = 0; $i <= $#chars; $i++) {
		my $charAt = $chars[$i];

		if ($charAt eq '\\') {
			$extracted .= $chars[$i].$chars[$i+1];
			$i++;
			next;
		}
		if ($charAt =~ /$terminator/) {
			if (isBalanced($balanced)) {
				return $extracted;
			}
		}

		unless ($isQuoting) {	
			if ($charAt =~ /["']/) { #'"
				$isQuoting = 1;
				$outerQuoteChar = $charAt;
				$balanced->{$charAt} ++;
			} elsif ($charAt =~ /[\[\{\(]/ ) {
				$balanced->{$charAt} ++;
			} elsif ($charAt eq ']') {
				$balanced->{'['} --;
			} elsif ($charAt eq '}') {
				$balanced->{'{'} --;
			} elsif ($charAt eq ')') {
				$balanced->{'('} --;
			}
		} else {
			if ($charAt eq $outerQuoteChar) {
				$isQuoting = 0;
				$outerQuoteChar = '';
				$balanced->{$charAt} ++;
			}
		}

		$extracted .= $charAt;
	}
	if (isBalanced($balanced)) {
		return $extracted;
	} else {
		croak "Error parsing message $chunk; unbalanced ".unbalanced($balanced);
	}
	return "";
}

sub isBalanced {
	my $balanced = shift;
	foreach my $char (keys %$balanced) {
		return 0 if ($char =~ /[\[\{\(]/ && $balanced->{$char} != 0);
		return 0 if ($char =~ /["']/ && $balanced->{$char} % 2 != 0);
	}
	return 1;
}

sub unbalanced {
	my $balanced = shift;
	foreach my $char (keys %$balanced) {
		return $char if ($char =~ /[\[\{\(]/ && $balanced->{$char} != 0);
		return $char if ($char =~ /["']/ && $balanced->{$char} % 2 != 0);
	}
}

1;
