src/jcplib/tree.pm

use v5.16;
package jcplib::tree;
use strict;
use warnings FATAL => 'all';
use Exporter 'import';
use jcplib::util qw(stage_err);
 
our @EXPORT_OK = qw(read_tree write_tree mk find_kid atom_esc atom_unesc);
 
# the shared s-expression tree format every IR-holding stage (jparse1's
# cst through jdesugar4's cast) reads and writes. one stage's output is
# the next stage's input, so the reader/writer must round-trip exactly;
# it is deliberately dumb -- no grammar knowledge here, just structure.
#
# a node is (op, atoms, kids):
#   node := {op => "name", atoms => ["at=3:1", "i32", ...], kids => [node...]}
#
# serialized form (the .j1..j4 file format):
#   - a leaf node (no kids) is one line: (op atom atom ...)
#   - a node whose kids are ALL leaves renders them inline on its
#     opener line (after its atoms); a node with even one non-leaf kid
#     puts every kid on its own line indented one tab deeper and glues
#     its closing ')' to the end of the last line. exactly one node
#     opener per line, closers trail the last line of the subtree
#     they close. inline leaves never mix with below-the-line kids
#     (the reader could not recover the interleaving order).
#
# atoms are escaped so a line never contains a raw space or paren:
# backslash -> \x5C, space -> \x20, ( -> \x28, ) -> \x29, every other
# non-graphic byte -> \xHH. a string literal atom like "foo bar" is
# carried as its exact bytes and survives the format unbroken.
 
sub atom_esc {
	my ($s) = @_;
	$s =~ s/([\\ ()]|[^\x20-\x7E])/sprintf("\\x%02X", ord($1))/ge;
	return $s;
}
 
sub atom_unesc {
	my ($s) = @_;
	$s =~ s/\\x([0-9A-Fa-f]{2})/chr(hex($1))/ge;
	return $s;
}
 
sub mk {
	my ($op, $atoms, $kids) = @_;
	return {op => $op, atoms => ($atoms // []), kids => ($kids // [])};
}
 
sub find_kid {
	my ($node, $op) = @_;
	for my $k (@{$node->{kids}}) { return $k if $k->{op} eq $op; }
	return undef;
}
 
sub render {
	my ($node, $depth) = @_;
	my $pad = "\t" x $depth;
	my $line = $pad . '(' . $node->{op};
	$line .= ' ' . join(' ', map { atom_esc($_) } @{$node->{atoms}}) if @{$node->{atoms}};
	# leaf kids go inline on the opener line ONLY when every kid is
	# a leaf -- mixing inline leaves with below-the-line kids would
	# lose the interleaving order when read back (the reader can only
	# put all inline kids before all below kids), so a node with even
	# one non-leaf kid puts every kid on its own line.
	my $all_leaf = 1;
	for my $k (@{$node->{kids}}) { $all_leaf = 0 if @{$k->{kids}}; }
	my (@out);
	if($all_leaf) {
		for my $k (@{$node->{kids}}) {
			$line .= ' (' . $k->{op};
			$line .= ' ' . join(' ', map { atom_esc($_) } @{$k->{atoms}}) if @{$k->{atoms}};
			$line .= ')';
		}
		return ($line . ')');
	}
	push @out, $line;
	for my $k (@{$node->{kids}}) { push @out, render($k, $depth + 1); }
	$out[-1] .= ')';
	return @out;
}
 
sub write_tree {
	my ($node) = @_;
	return join("\n", render($node, 0)) . "\n";
}
 
# char-wise scan of one opener line's remainder: plain atoms,
# inline leaf nodes (a balanced (....) with no nesting inside -- by
# construction a leaf can't nest), and trailing ')' runs (glued closers,
# possibly attached directly to the last atom's text).
sub parse_rest {
	my ($rest) = @_;
	my (@atoms, @inline, $closers);
	$closers = 0;
	my $i = 0;
	my $len = length $rest;
	my $cur = '';
	while($i < $len) {
		my $c = substr($rest, $i, 1);
		if($c eq ' ') {
			push @atoms, atom_unesc($cur) if length $cur;
			$cur = '';
		}
		elsif($c eq '(') {
			my $j = index($rest, ')', $i + 1);
			stage_err("tree: unbalanced inline node in: $rest") unless $j >= 0;
			push @inline, leaf_of(substr($rest, $i, $j - $i + 1));
			$i = $j;
		}
		else { $cur .= $c; }
		$i++;
	}
	if(length $cur) {
		if($cur =~ /^(.*?)(\)+)$/) {
			push @atoms, atom_unesc($1) if length $1;
			$closers += length $2;
		}
		else { push @atoms, atom_unesc($cur); }
	}
	return (\@atoms, \@inline, $closers);
}
 
sub leaf_of {
	my ($s) = @_;
	stage_err("tree: bad inline node: $s") unless $s =~ /^\(([^\s()]+)(.*)\)$/;
	my ($op, $inner) = ($1, $2);
	my @atoms = map { atom_unesc($_) } grep { length } split ' ', $inner;
	return {op => $op, atoms => \@atoms, kids => []};
}
 
# recursive descent: one node per line, children indented one tab deeper,
# each node's own closer counted on the line that carries it. returns
# (node, extra_closers) where extra_closers is however many ')' beyond
# the node's own one the last consumed line carried -- the caller eats
# exactly one and keeps reading kids while its own closer hasn't arrived.
sub read_node {
	my ($lines, $i, $indent) = @_;
	my $line = $lines->[$$i];
	stage_err('tree: unexpected end of tree') unless defined $line;
	my $want = "\t" x $indent;
	stage_err("tree: bad indentation at line " . ($$i + 1)) unless index($line, $want) == 0;
	my $body = substr($line, length $want);
	# op is a run of non-space non-paren chars -- NOT \S+ (greedy \S+
	# would swallow the node's trailing closers into the op name).
	stage_err("tree: bad node opener at line " . ($$i + 1) . ": $line") unless $body =~ /^\(([^\s()]+)(.*)$/;
	my ($op, $rest) = ($1, $2);
	$$i++;
	my ($atoms, $inline, $closers) = parse_rest($rest);
	my @kids = @$inline;
	while($closers < 1) {
		my ($k, $extra) = read_node($lines, $i, $indent + 1);
		push @kids, $k;
		$closers += $extra;
	}
	return ({op => $op, atoms => $atoms, kids => \@kids}, $closers - 1);
}
 
sub read_tree {
	my ($text) = @_;
	my @lines = grep { /\S/ } split /\n/, $text;
	my $i = 0;
	my ($node, $extra) = read_node(\@lines, \$i, 0);
	stage_err('tree: trailing garbage after tree root') if $extra != 0 || $i != @lines;
	return $node;
}
 
1;