package Mylisp::Type;
use 5.012;
no warnings "experimental";
use Exporter;
our @ISA = qw(Exporter);
our @EXPORT =
qw(match_type pat_to_type_rule get_type_parser get_type_ast type_grammar mylisp_type_grammar new_parser load_str getchar match_type_pat match_type_rules match_type_branch match_type_token match_type_return match_type_rept match_type_str opt_type_ast map_opt_type_atom opt_type_atom opt_type_spec opt_type_rules opt_type_atoms gather_type_rept gather_type_branch opt_type_str opt_type_return is_branch pat_to_type_str rules_to_type_str branch_to_type_str rept_to_type_str);
use Spp;
use Spp::MatchRule;
use Spp::Tools;
use Spp::Builtin;
use Spp::Cursor;
use Spp::LintAst;
use Mylisp::Lint;
sub match_type {
my ($p, $rule, $str) = @_;
load_str($p, $str);
return match_type_pat($rule, $p);
}
sub pat_to_type_rule {
my ($t, $pat) = @_;
my $ast = $t->{'patter'};
my ($door, $table) = ast_to_table($ast);
$door = 'pat';
my $door_rule = $table->{$door};
my $cursor = new_cursor($pat, $table);
my $match = match_spp_rule($door_rule, $cursor);
if (not(is_false($match))) {
return opt_type_rules($match);
}
report($t, "could not transfer pat: |$pat| to rule!");
}
sub get_type_parser {
my $type_ast = get_type_ast();
my $grammar = mylisp_type_grammar();
my ($match, $ok) = match_text($type_ast, $grammar);
if ($ok) {
my $ast = opt_type_ast($match);
my ($__, $table) = ast_to_table($ast);
my $parser = new_parser($table);
return $parser;
}
else { say $match }
}
sub get_type_ast {
my $grammar = type_grammar();
my $ast = grammar_to_ast($grammar);
lint_spp_ast($ast);
return $ast;
}
sub type_grammar {
return <<'EOF'
door = |\s+ Spec|+ $ ;
Spec = Token \h+ '=' pat ;
pat = |\h+ Branch Token Str Rept Return|+ ;
Branch = '|' ;
Token = \a+ ;
Str = ':' \a+ ;
Rept = [+?] ;
Return = '->' |\s+ Token Str|+ ;
EOF
}
sub mylisp_type_grammar {
return <<'EOF'
Any = Bool|Str|Int|Array|Table|Null
Bool = :Bool
Str = :Str | :String | :Lstr | :Char
Int = :Int
Array = :Array
StrOrArray = Str|Array|Iarray
Iarray = :Iarray
Stable = :Stable
Hash = :Hash
Table = Stable|Hash
Cursor = :Cursor
Lint = :Lint
Parser = :Parser
Null = :Null
Fn = :Fn
EOF
}
sub new_parser {
my $table = shift;
{ 'str' => '', 'off' => 0, 'ns' => $table };
}
sub load_str {
my ($p, $str) = @_;
$p->{'str'} = add($str, End);
$p->{'off'} = 0;
}
sub getchar {
my $p = shift;
return substr($p->{'str'}, $p->{'off'}, 1);
}
sub match_type_pat {
my ($rule, $p) = @_;
my ($name, $value) = flat($rule);
given ($name) {
when ('Rules') { return match_type_rules($value, $p) }
when ('Branch') { return match_type_branch($value, $p) }
when ('Rept') { return match_type_rept($value, $p) }
when ('Str') { return match_type_str($value, $p) }
when ('Return') { return match_type_return($value, $p) }
when ('Token') { return match_type_token($value, $p) }
default { say "unknown rule: $name to match!" }
}
}
sub match_type_rules {
my ($rules, $p) = @_;
my $return = False;
for my $rule (@{ atoms($rules) }) {
my $match = match_type_pat($rule, $p);
if (is_false($match)) { return False }
$return = $match;
}
return $return;
}
sub match_type_branch {
my ($branch, $p) = @_;
my $off = $p->{'off'};
for my $rule (@{ atoms($branch) }) {
my $match = match_type_pat($rule, $p);
if (not(is_false($match))) { return $match }
$p->{'off'} = $off;
}
return False;
}
sub match_type_token {
my ($name, $p) = @_;
my $table = $p->{'ns'};
my $rule = $table->{$name};
my $match = match_type_pat($rule, $p);
if (is_false($match)) { return False }
return True;
}
sub match_type_return {
my ($return, $p) = @_;
return $return;
}
sub match_type_rept {
my ($rule, $p) = @_;
my $time = 0;
my ($rept, $atom) = flat($rule);
my ($min, $max) = get_rept_time($rept);
while ($time != $max) {
my $off = $p->{'off'};
my $match = match_type_pat($atom, $p);
if (is_false($match)) {
if ($time < $min) { return False }
$p->{'off'} = $off;
return True;
}
$time++;
}
return True;
}
sub match_type_str {
my ($str, $p) = @_;
for my $char (split '', $str) {
if ($char ne getchar($p)) { return False }
$p->{'off'}++;
}
return True;
}
sub opt_type_ast {
my $ast = shift;
if (is_atom($ast)) { return cons(opt_type_atom($ast)) }
return map_opt_type_atom($ast);
}
sub map_opt_type_atom {
my $atoms = shift;
return estr(
[map { opt_type_atom($_) } @{ atoms($atoms) }]);
}
sub opt_type_atom {
my $atom = shift;
my ($name, $value) = flat($atom);
given ($name) {
when ('Spec') { return opt_type_spec($value) }
when ('Str') { return opt_type_str($value) }
when ('Return') { return opt_type_return($value) }
when ('Rept') { return cons('rept', $value) }
when ('Branch') { return cons('branch', $value) }
when ('Token') { return cons('Token', $value) }
default { say "unknown atom: |$name|" }
}
}
sub opt_type_spec {
my $atoms = shift;
my ($token, $rules) = match($atoms);
my $name = value($token);
my $rule = opt_type_atoms($rules);
return cons($name, $rule);
}
sub opt_type_rules {
my $rules = shift;
if (is_atom($rules)) { return $rules }
return opt_type_atoms($rules);
}
sub opt_type_atoms {
my $atoms = shift;
$atoms = map_opt_type_atom($atoms);
$atoms = gather_type_rept($atoms);
$atoms = gather_type_branch($atoms);
return $atoms;
}
sub gather_type_rept {
my $atoms = shift;
my $opt_atoms = [];
my $flag = 0;
my $cache = '';
for my $atom (@{ atoms($atoms) }) {
if ($flag == 0) {
if (not(is_rept($atom))) { $cache = $atom; $flag = 1 }
}
else {
if (is_rept($atom)) {
my $rept = value($atom);
$cache = cons('Rept', cons($rept, $cache));
push @{$opt_atoms}, $cache;
$flag = 0;
}
else { push @{$opt_atoms}, $cache; $cache = $atom }
}
}
if ($flag == 1) { push @{$opt_atoms}, $cache; }
return estr($opt_atoms);
}
sub gather_type_branch {
my $atoms = shift;
my $branches = [];
my $branch = [];
my $flag = 0;
my $count = 0;
for my $atom (@{ atoms($atoms) }) {
if (is_branch($atom)) {
if ($count > 1) {
push @{$branches}, cons('Rules', $branch);
}
else { push @{$branches}, $branch->[0]; }
$flag = 1;
$branch = [];
$count = 0;
}
else { push @{$branch}, $atom; $count++ }
}
if ($flag == 0) {
if ($count == 1) { return $branch->[0] }
else { return cons('Rules', $branch) }
}
if ($count > 1) {
push @{$branches}, cons('Rules', $branch);
}
else { push @{$branches}, $branch->[0]; }
return cons('Branch', $branches);
}
sub opt_type_str {
my $str = shift;
return cons('Str', substr($str, 1));
}
sub opt_type_return {
my $return = shift;
my $tokens = atoms($return);
my $str = join ' ', @{ [map { value($_) } @{$tokens}] };
return cons('Return', $str);
}
sub is_branch {
my $atom = shift;
return is_atom_name($atom, 'branch');
}
sub pat_to_type_str {
my $pat = shift;
my ($name, $value) = flat($pat);
given ($name) {
when ('Rules') { return rules_to_type_str($value) }
when ('Branch') { return branch_to_type_str($value) }
when ('Str') { return ":$value" }
when ('Token') { return $value }
when ('Rept') { return rept_to_type_str($value) }
when ('Return') { return "-> $value" }
default { say "unknown pattern name: |$name| to str" }
}
}
sub rules_to_type_str {
my $rules = shift;
my $rules_strs = [];
for my $rule (@{ atoms($rules) }) {
push @{$rules_strs}, pat_to_type_str($rule);
}
return join ' ', @{$rules_strs};
}
sub branch_to_type_str {
my $branches = shift;
my $branch_strs = [];
for my $branch (@{ atoms($branches) }) {
push @{$branch_strs}, pat_to_type_str($branch);
}
return join '|', @{$branch_strs};
}
sub rept_to_type_str {
my $rule = shift;
my ($rept, $atom) = flat($rule);
my $atom_str = pat_to_type_str($atom);
return add($atom_str, $rept);
}
1;