package Shiar_Sheet::FormatChar;

use strict;
use warnings;

use Data::Dump 'pp';
use PLP::Functions 'EscapeHTML';

our $VERSION = '1.04';

our $diinfo = do 'digraphs.inc.pl';
our %di = map { $diinfo->{$_}->[0] => $_ } grep { ref $diinfo->{$_} }
	sort { length $a <=> length $b } keys %$diinfo;

sub new {
	my ($class) = @_;
	bless { anno => ['di', 0], style => 'di' }, $class;
}

sub glyph_info {
	my ($self, $codepoint) = @_;
	if (defined (my $mnem = $di{$codepoint})) {
		return ($diinfo->{$mnem}, length $mnem == 2 ? $mnem : undef);
	}
	require Unicode::UCD;
	if (my $fullinfo = Unicode::UCD::charinfo($codepoint)) {
		return [$codepoint, @$fullinfo{qw/name category script string/}];
	}
	return [$codepoint];
}

sub glyph_html {
	my ($self, $char) = @_;
	my ($info, $mnem) = $self->glyph_info(ord $char);
	my ($codepoint, $name, $prop, $script, $string) = @$info;

	my $cell = EscapeHTML($string || $char);
	my $title = sprintf 'U+%04X%s', $codepoint, $name && " ($name)";
	my @class = ('X', grep {$_} $prop, $script);

	$cell = "<span>$cell</span>" if $prop and $prop eq 'Zs';
	$cell = '&nbsp;' if $cell eq '';

	return ($cell, EscapeHTML($title), join(' ', @class), $mnem);
}

sub glyphs_html {
	my $self = shift;

	return $self->glyph_html(@_) if length $_[0] <= 1;

	my @chars = map { [ $self->glyph_html($_) ] } split //, $_[0];
	return (
		EscapeHTML($_[0]), # cell
		join(' | ', map { $_->[1] } @chars), # title
		$chars[0][2], # class
		join(' ',  grep { defined } map { $_->[3] } @chars), # digraph
	);
}

sub glyph_cell {
	my ($self, $char) = @_;
	return sprintf('<td class="%3$s" title="%2$s">%s', $self->glyph_html($char));
}

sub cell {
	my ($self, $input, $html) = @_;
	my (@class, $title, $cell, $mnem);

	if ($input eq '-') {
		$cell = '';
	}
	elsif ($input eq '=') {
		push @class, 'u-invalid';
		$cell = '';
	}
	else {
		push @class, 'X';

		if ($input =~ s/^-//) {
			push @class, 'ex'; # discouraged
		}

		($cell, $title, my $class, $mnem) = $self->glyphs_html($input);

		if ($self->{style} = 'di') {
			if (defined $mnem) {
				push @class, $class =~ /\bXz\b/ ? ('l2', 'u-prop') # unofficial
					: ('l3', 'u-di'); # standard digraph
			}
		}
		else {
			my $codepoint = ord(substr $input, 0, 1);
			if ($codepoint <= 0xFF) {
				push @class, 'l3', 'u-lat1';  # latin1
			}
			elsif ($codepoint <= 0xD7FF) {
				push @class, 'l2', 'u-bmp';  # bmp
			}
		}

		if ($input =~ /[ -~]/) {
			push @class, 'l4', 'u-ascii'; # ascii
		}
		else {
			push @class, 'l1'; # basic unicode
		}
	}

	my $anno = '';
	for (@{ $self->{anno} }) {
		if ($_ eq 'html') {
			require HTML::Entities;
			if (my $_ = $HTML::Entities::char2entity{$cell}) {
				$anno = sprintf(' <small class="digraph">%s</small>', EscapeHTML($_));
				last;
			}
		}
		elsif ($_ eq 'xml') {
			require HTML::Entities;
			$anno = sprintf(' <small class="digraph">%s</small>',
				sprintf "&amp;#%d;", ord($cell)
			);
			last;
		}
		elsif ($_ eq 'di') {
			if (defined $mnem and length $mnem) {
				$anno = sprintf(' <small class="digraph">%s</small>', EscapeHTML($mnem));
				last;
			}
		}
		else {
			if ($_ eq 'hex' or $cell =~ /^[^a-zA-Z]$/) {
				$anno = sprintf(' <small class="%s">%04X</small>', 'value', ord $cell);
				last;
			}
		}
	}

	return sprintf('<td%s%s%s>%s%s',
		defined $title  ? qq{ title="$title"}  : '',
		@class ? sprintf(' class="%s"', join ' ', @class) : '',
		$html || '',
		$cell eq '' ? '&nbsp;' : $cell,
		$anno,
	);
}

sub table {
	my ($self, $digraphs) = @_;

	my @rows;

	my @colheads;
	while ($digraphs->[0] !~ /^\./) {
		my $cell = shift @$digraphs or last;
		push @colheads, sprintf(
			'<%s%s>%s',
			$cell =~ s/^-// ? 'td' : 'th',
			$cell =~ s/:(.*)// ? qq{ title="$1"} : '',
			$cell eq '_' ? '&nbsp;' : $cell
		);
	}
	push @rows, sprintf '<thead><tr>%s<tbody>', join '', @colheads if @colheads;

	my $colspan = 1;
	for my $cell (@$digraphs) {
		if ($cell =~ s/^\.//) {
			# dot indicates start of a new row
			push @rows, '<tr>';
			if ($cell =~ s/^>//) {
				# header cell text follows
				$cell =~ s/_/ /g;  # underscores may be used instead of whitespace (for qw//ability)
				$rows[-1] .= '<th>'.($cell || '&nbsp;');
			}
			next;
		}
		elsif ($cell eq '>') {
			# merge this cell to the next column
			$colspan++;
			next;
		}

		$rows[-1] .= $self->cell($cell,
			$colspan > 1 && qq{ colspan="$colspan"},
		);

		$colspan = 1;
	}

	return sprintf qq{<table class="glyphs%s">\n%s</table>\n},
		@{ $self->{anno} } ? ' dilabel' : '',
		join '', map {"$_\n"} @rows;
}

sub print {
	my $self = shift;
	while (@_) {
		printf '<div class="section"><h2>%s</h2>'."\n\n", shift;
		while (ref $_[0] and $_ = shift) {
			print $self->table($_);
		}
		print '</div>';
	}
}

1;

