#!/usr/bin/perl
#
#	cpm-v2:	a prototype "C with pattern matching" to C translator..
#
#	This second version of our tool reads every line of input,
#	identifies %when lines, copies all other lines to stdout
#	unchanged, and then parses each %when line into it's pieces.
#	Still quite easy in Perl!

#	(C) June 2018, Duncan C. White
#

use strict;
use warnings;
use 5.010;
use Data::Dumper;
use Function::Parameters;


my $infh;		# fd of current C+PM file we're translating
my $lineno = 0;		# current line no inside $infh
my $currline;		# current line (set by nextline(), used in fatal())


#
# my $line = nextline();
#	Read the next line from $infh, incrementing $lineno afterwards,
#	and return it.
#
fun nextline()
{
	my $line = <$infh>;
	$currline = $line;
	$lineno++;
	return $line;
}


#
# fatal( $whatsleft, $msg );
#	Given $whatsleft (a suffix of $currline) and a message $msg, print
#	a standard-formatted fatal error, pointing to the correct place in
#	the line (using length(currline) - length(whatsleft) as the basic
#	source of indentation information), and die.
#
fun fatal( $whatsleft, $msg )
{
	$currline =~ s/^\t/        /;		# expand tabs to spaces
	$whatsleft =~ s/^\t/        /;
	my $pos = length($currline) - length($whatsleft) - 1;
	my $indent = ' ' x $pos;
	my $err = "$currline$indent^ Error at line $lineno: $msg\n";
	die "\n$err\n";
}


#
# my( $command, $type, $var, $shape, $arglist ) = parse_when( $line );
#	After checking that $line starts with a %when, parse the rest of the
#	line.  If it parses return (command, type, var, shape, arglist)
#	otherwise die via fatal()
#
#	'%when' TYPE(ID) VAR(ID) 'is' SHAPE(ID) ( '(' ARGLIST ')' )
#	where ARGLIST is a comma separated list of typename paramname pairs,
#	where the typename and the paramname are IDs.
#
fun parse_when( $line )
{
	$line =~ s/^(%\S+)\s*//;
	my $command = $1;
	$command =~ s/shape$//;	# %when or %whenshape etc.. reduce to %when
	my $sofar = $command;

	fatal( $line, "ID (type name) expected after <<$sofar>>" )
		unless $line =~ s/^(\w+)\s+//;
	my $type = $1;
	$sofar .= " $type";

	fatal( $line, "ID (var name) expected after <<$sofar>>" )
		unless $line =~ s/^(\w+)\s+//;
	my $var = $1;
	$sofar .= " $var";

	fatal( $line, "'is' expected after <<$sofar>>" )
		unless $line =~ s/^is\s+//;
	$sofar .= " is";

	fatal( $line, "ID (constructor name) expected after <<$sofar>>" )
		unless $line =~ s/^(\w+)\s*//;
	my $shape = $1;
	$sofar .= " $shape";

	# that may be all..
	return( $command, $type, $var, $shape, "" ) if $line =~ /^\s*$/;

	# or we need '(' arglist ')'
	fatal( $line, "'(' expected after <<$sofar>>" )
		unless $line =~ s/^\(\s*//;

	fatal( substr($line,-1,1), "')' expected at end of line" ) unless
		$line =~ s/\s*\)$//;

	# should have an arglist left now.  should really check it's
	# syntactically valid but let's not bother...
	return( $command, $type, $var, $shape, $line );
}


#
# my $breakdown = take_object_apart( $type, $var, $shape, $arglist );
#	Generate a single long line of C code that will take the object
#	apart, into it's component arguments. Return the take apart string..
#
fun take_object_apart( $type, $var, $shape, $arglist )
{
	# if the shape has no arguments, then we don't need to take it apart
	return "" unless $arglist;

	# ok, we have one or more arguments, comma separated:
	my @arg = split(/\s*,\s*/, $arglist );
	foreach my $arg (@arg)
	{
		my( $argtype, $argname ) = split( /\s+/, $arg, 2 );
		print "debug: toa: type $type, shape=$shape, ".
		      "argtype=$argtype, argname=$argname\n";
	}
	return "// TAKE APART CODE GOES HERE";
}


#
# handle_when( $line, $indent, $ofh );
#	Ok, $line starts with a %when (still in the line), and we've already
#	removed any leading indentation (in $indent).  Handle the %when line
#	and it's following '{', printing valid C output to $ofh.
#
fun handle_when( $line, $indent, $ofh )
{
	my( $command, $type, $var, $shape, $arglist ) = parse_when( $line );
	#print "debug: found $command type=$type, var=$var, shape=$shape, ".
	#	"arglist=$arglist\n";

	# produce the %when comment line
	print $ofh "$indent// $line:\n";

	# produce the if-line
	my $test = "${type}_kind($var) == ${type}_is_${shape}";
	print $ofh "${indent}if( $test )\n";

	# get the next line, check that it's a bare '{', and print it out
	my $line = nextline();
	fatal( $line, "$command: { expected at eof" ) unless defined $line;
	fatal( $line, "$command: bare { expected at same indentation, " )
		unless $line =~ /^$indent\s*\{\s*$/;
	print $ofh $line;

	# then print out code to take the object apart
	my $takeapart = take_object_apart( $type, $var, $shape, $arglist );
	print $ofh "${indent}\t$takeapart" if $takeapart;
}


#
# handle_line( $line, $ofh );
#	handle $line [and if necessary, any subsequent lines of input],
#	print out whatever text is generated (or copied) to $ofh
#
fun handle_line( $line, $ofh )
{
	unless( $line =~ /^\s*%/ )
	{
		print $ofh "$line\n";
		return;
	}
	$line =~ s/^(\s*)//;
	my $indent = $1;
	print "debug: line is <<$line>> at line $lineno\n";

	fatal( $line, "%when expected" ) unless $line =~ /^%when/;
	handle_when( $line, $indent, $ofh );
}


die "Usage: cpm-v2 inputfile\n" unless @ARGV == 1;
my $inputfilename = shift;

my $cfilename = $inputfilename;
$cfilename =~ s/pm$//;

open( $infh, '<', $inputfilename ) || die "cpm: can't open $inputfilename\n";

unlink( $cfilename );
open( my $cfh, '>', $cfilename ) || die "cpm: can't create $cfilename\n";

while( defined( $_ = nextline() ) )
{
	chomp;
	handle_line( $_, $cfh );
}
close( $infh );
close( $cfh );
