EastAsianWidth判別用コードを自動生成する

VisualWidth実装用に、Unicode::EastAsianWidth みたいなものを自動生成するためのスクリプトを書いた。unicode.orgからとってきたデータをもとに生成しているので安心。

これはJSX用だけど、他の適当な言語のためのコードを生成するのも難しくないはず。

#!/usr/bin/env perl
use 5.14.0;
use strict;
use warnings;
use LWP::Simple qw(get);
use Text::Xslate;
use Log::Minimal qw(infof);

my $SPEC = "http://www.unicode.org/reports/tr11/";
my $DATA = "http://www.unicode.org/Public/UNIDATA/EastAsianWidth.txt";

my %params = (
    spec_uri => $SPEC,
    data_uri => $DATA,

    F  => [],
    W  => [],
    H  => [],
    N  => [],
    Na => [],
    A  => [],
);

infof 'get data from %s', $DATA;
my $data = get($DATA);

infof 'parse character tratis';
my @traits;
for my $line(split /\n/, $data) {
    $line =~ s/\#.*//;
    if ($line =~ m{ (?<code_first> \w+) \.\.(?<code_last> \w+) ; (?<trait> \w+) }xms) {
        for my $code(hex($+{code_first}) .. hex($+{code_last})) {
            $traits[$code] = $+{trait};
        }
    }
    elsif ($line =~ m{ (?<code> \w+) ; (?<trait> \w+) }xms) {
        $traits[hex $+{code}] = $+{trait};
    }
}
infof 'make ranges from traits';

my $c    = 0;
my $trait = "";
my $first = -1;
foreach my $t(@traits) {
    next unless $t;

    if ($t ne $trait) {
        if ($trait ne "" && $first != -1) {
            push $params{$trait}, [ $first, $c - 1 ];
        }

        $first = $c;
        $trait = $t;
    }
}
continue {
    ++$c;
}

infof 'render it';

my $xslate = Text::Xslate->new(
    type  => "text",
    cache => 0,
    module => ['Text::Xslate::Bridge::Star'],
);

print $xslate->render_string(do {
        local $/;
        <DATA>;
    }, \%params);

__DATA__
// THIS FILE IS AUTOMATICALLY GENERATED.
// DO NOT EDIT IT!

// spec: <: $spec_uri :>
// data: <: $data_uri :>

class EastAsianWidth {
    static function isFullWidth(c : int) : boolean {
        return EastAsianWidth.isFullWidth(c, true);
    }

    static function isFullWidth(c : int, inEastAsian : boolean) : boolean {
        if (   EastAsianWidth.W(c)
            || EastAsianWidth.F(c) ) {
            return true;
        }

        return inEastAsian && EastAsianWidth.A(c);
    }

    // character traits

<:-
macro range -> $r {
    if $r[0] == $r[1] {
        sprintf("(c == 0x%08X)", $r[0]);
    }
    else {
        sprintf("(0x%08X <= c && c <= 0x%08X)", $r[0], $r[1]);
    }
}
-:>
: macro make_conditions -> $t, $name {
    static function <: $name :>(c : int) : boolean {
        return
        : for $t -> $range {
            <: range($range) ~ ($~range.is_last ? "" : " ||") :>
        : }
        ;
    } // <: $name :>
: }

    : make_conditions($W, "W");

    : make_conditions($F, "F");

    : make_conditions($A, "A");
}

Perl 5.10から使える named capture や Perl 5.14から使える push $array_ref, ... が非常に便利でいいですね。