# HG changeset patch
# User Maxim Dounin <mdounin@mdounin.ru>
# Date 1392909402 -14400
# Node ID 0fa786e03744939cd9714516a6c747690b91ef5f
# Parent  bcd96c4038985403068c40d65f6bad4408a3387c
XSLScript: some preliminary work on conversion.

The aproach seems to be wrong though, it looks like the only correct
way is to build a tree, and then process the tree.  Major changes
expected.

diff --git a/xsls.pl b/xsls.pl
--- a/xsls.pl
+++ b/xsls.pl
@@ -36,15 +36,18 @@ my $grammar = <<'EOF';
 # XSLTScript grammar, reconstructed
 
 startrule	: item(s) eofile
-		{ $return = $item[1] }
+	{ $return = $item[1]; 1 }
 
 item		: "<!--" <commit> comment
-		| "!!" <commit> double_exclam
+		| "!!" <commit> exclam_double
 		| "!{" <commit> exclam_xpath
 		| "!" name <commit> exclam_name
 		| "<%" <commit> instruction "%>"
+	{ $return = $item{instruction}; 1 }
 		| "<" name attrs ">" <commit> item(s?) "</" name ">"
+	{ $return = ::format_tag($item{name}, $item{attrs}, $item[6]); 1 }
 		| "<" <commit> name attrs "/" ">"
+	{ $return = ::format_tag($item{name}, $item{attrs}); 1 }
 		| "X:variable" <commit> xvariable
 		| "X:var" <commit> xvariable
 		| "X:template" <commit> xtemplate
@@ -57,6 +60,9 @@ item		: "<!--" <commit> comment
 		| "X:output" <commit> xoutput
 		| "X:copy-of" <commit> xcopyof
 		| instruction <commit> attrs body
+	{ $return = ::format_instruction(
+		$item{instruction}, $item{attrs}, $item{body});
+	1 }
 		| text
 		| <error>
 
@@ -91,27 +97,28 @@ instruction	: "X:stylesheet"
 # likely an artifact of our dump process
 
 comment		: /((?!-->).)*/ms "-->"
-		{ $return = ""; 1; }
+	{ $return = "<!-- " . $item[1] . "-->"; 1; }
 
 # special chars: ', ", {, }, \
 # if used in text, they needs to be escaped with backslash
 
 text		: quoted | unreserved | "'" | "\"" | "{"
 quoted		: "\\" special
-		{ $return = $item{special}; 1; }
+	{ $return = $item{special}; 1; }
 special		: "'" | "\"" | "\\" | "{" | "}"
 unreserved	: /[^'"\\{}]/
 
 # shortcuts:
 #
+# !! for X:apply-templates
 # !{xpath-expression} for X:value-of select="xpath-expression";
-# !! for X:apply-templates
 # !foo() for X:call-template name="foo"
 
 # !root (path = { !{ substring($DIRNAME, 2) } })
 # !root (path = "substring-after($path, '/')")
 
-double_exclam	: value(?) params attrs ";"
+exclam_double	: value(?) params(?) attrs ";"
+	{ $return = ::format_apply($item{value}, $item{params}, $item{attrs}); 1 }
 
 exclam_xpath	: xpath(s?) "}"
 xpath		: /[^}'"]+/
@@ -131,8 +138,8 @@ value		: /"[^"]*"/
 # template parameters
 # ( bar="init", baz={markup} )
 
-params		: "(" param ("," param)(s?) ")"
-		| ""
+params		: "(" param(s /,/) ")" 
+	{ $return = $item[2]; 1 }
 param		: name "=" value
 		| name "=" <commit> "{" item(s) "}"
 		| name
@@ -141,7 +148,9 @@ param		: name "=" value
 # ";" for empty body, "{ ... }" otherwise
 
 body		: ";"
+	{ $return = ""; }
 		| "{" <commit> item(s?) "}"
+	{ $return = join("\n", @{$item[3]}); 1 }
 
 # special handling of some instructions
 # X:if attribute is test=
@@ -153,7 +162,7 @@ xif		: value(?) attrs body "else" <commi
 # X:template name(params) = "match" {
 # X:template name( bar="init", baz={markup} ) = "match" mode="some" {
 
-xtemplate	: name(?) params ( "=" value )(?)
+xtemplate	: name(?) params(?) ( "=" value )(?)
 		  attrs body
 
 # X:var LINK = "/article/@link";
@@ -173,32 +182,48 @@ xparam		: name ("=" value)(?) attrs body
 # X:for-each "link", X:sort "@id" {
 
 xforeach	: value attrs body
+	{ $return = ::format_instruction_value(
+		"X:for-each", "select", $item{value}, $item{attrs}, $item{body});
+	1 }
 		| value attrs "," "X:sort" <commit> value attrs body
 
 # X:sort select
 # X:sort "@id"
 
 xsort		: value attrs body
+	{ $return = ::format_instruction_value(
+		"X:sort", "select", $item{value}, $item{attrs}, $item{body});
+	1 }
 
 # X:when "position() = 1" { ... }
 
 xwhen		: value attrs body
+	{ $return = ::format_instruction_value(
+		"X:when", "test", $item{value}, $item{attrs}, $item{body});
+	1 }
 
 # X:attribute "href" { ... }
 
 xattribute	: value attrs body
+	{ $return = ::format_instruction_value(
+		"X:attribute", "name", $item{value}, $item{attrs}, $item{body});
+	1 }
 
 # X:output
 # semicolon is optional
 
-xoutput		: attrs body
-		| attrs
+xoutput		: attrs body(?)
+	{ $return = ::format_instruction(
+		"X:output", $item{attrs}, $item{body});
+	1 }
 
 # "X:copy-of"
 # semicolon is optional
 
-xcopyof		: value attrs body
-		| value
+xcopyof		: value attrs body(?)
+	{ $return = ::format_instruction_value(
+		"X:copy-of", "select", $item{value}, $item{attrs}, $item{body});
+	1 }
 
 # eof
 
@@ -208,6 +233,74 @@ EOF
 
 ###############################################################################
 
+# helper formatting functions, used by grammar
+
+sub format_instruction {
+	my ($instruction, $attrs, $body) = @_;
+	my $s = "<";
+
+	$instruction =~ s/^X:/xsl:/;
+
+	$s .= join(" ", $instruction, @{$attrs});
+
+	if ($body) {
+		$s .= ">\n" . $body . "\n</" . $instruction . ">\n";
+	} else {
+		$s .= "/>\n";
+	}
+
+	return $s;
+}
+
+sub format_instruction_value {
+	my ($instruction, $name, $value, $attrs, $body) = @_;
+	my $s = "<";
+
+	if ($value) {
+		push(@{$attrs}, "$name=$value");
+	}
+
+	return format_instruction($instruction, $attrs, $body);
+}
+
+sub format_tag {
+	my ($tag, $attrs, $body) = @_;
+	my $s = "\n<";
+
+	$s .= join(" ", $tag, @{$attrs});
+
+	$body = join("\n", @{$body});
+
+	if ($body) {
+		$s .= ">" . $body . "\n</" . $tag . ">\n";
+	} else {
+		$s .= "/>\n";
+	}
+
+	return $s;
+}
+
+sub format_apply {
+	my ($select, $params, $attrs) = @_;
+	my $s = "\n<";
+	my $tag = "xsl:apply-templates";
+
+	if ($select) {
+		unshift "select=$select", @{$attrs};
+	}
+
+	$s .= join(" ", $tag, @{$attrs});
+
+	if ($params) {
+		$params = join("\n", @{$params});
+		$s .= ">\n" . $params . "\n</" . $tag . ">\n";
+	} else {
+		$s .= "/>\n";
+	}
+}
+
+###############################################################################
+
 my $parser = Parse::RecDescent->new($grammar)
 	or die "Failed to create parser.\n";
 
@@ -221,7 +314,8 @@ my $lines;
 my $tree = $parser->startrule($lines)
 	or die "Failed to parse $ARGV.\n";
 
-print Dumper($tree);
+#print Dumper($tree);
+#print join("\n", @{$tree});
 
 ###############################################################################
 ###############################################################################