package Mylisp::LintAst;
use 5.012;
no warnings "experimental";
use Exporter;
our @ISA = qw(Exporter);
our @EXPORT =
qw(lint_mylisp_ast init_mylisp_lint use_package load_package load_ast my_func get_mylisp_atoms_value my_const lint_mylisp_atoms lint_mylisp_atom lint_mylisp_cond_atoms lint_mylisp_exprs lint_mylisp_func get_return_type_str lint_mylisp_return get_atoms_type_str lint_mylisp_my lint_mylisp_our lint_mylisp_call get_args_type_str lint_mylisp_for lint_mylisp_set lint_mylisp_sym_list lint_mylisp_sym get_atom_type get_sym_type get_call_type get_array_type get_arange_type get_iter_type lint_mylisp_aindex get_aindex_type get_index_type);
use Spp::Builtin;
use Spp::Tools;
use Spp;
use Mylisp::Grammar;
use Mylisp::OptAst;
use Mylisp::Lint;
use Mylisp::Type;
sub lint_mylisp_ast {
my ($t, $ast) = @_;
init_mylisp_lint($t, $ast);
print "init ok ..\n";
lint_mylisp_atoms($t, $ast);
}
sub init_mylisp_lint {
my ($t, $ast) = @_;
for my $expr (@{ atoms($ast) }) {
my ($name, $args) = flat($expr);
update_pos($t, $expr);
given ($name) {
when ('package') { in_package($t, $args) }
when ('use') { use_package($t, $args) }
when ('const') { my_const($t, $args) }
when ('func') { my_func($t, $args) }
}
}
}
sub use_package {
my ($t, $args) = @_;
load_package($t, $args);
my $table = $t->{'st'}{$args};
for my $name (keys %{$table}) {
next if start_with($name, '_');
my $value = $table->{$name};
set_name_value($t, $name, $value);
}
}
sub load_package {
my ($t, $package) = @_;
my $dirs = [split '::', $package];
my $path = join '/', @{$dirs};
my $ast_file = add($path, ".spp.estr");
my $ast = read_file($ast_file);
print "load ast $ast_file ok\n";
load_ast($t, $ast);
}
sub load_ast {
my ($t, $ast) = @_;
for my $expr (@{ atoms($ast) }) {
my ($name, $args) = flat($expr);
update_pos($t, $expr);
given ($name) {
when ('package') { in_package($t, $args) }
when ('func') { my_func($t, $args) }
when ('const') { my_const($t, $args) }
when ('end') { out_ns($t) }
}
}
}
sub my_func {
my ($t, $atoms) = @_;
my ($name_args, $return) = flat($atoms);
my $return_type = get_mylisp_atoms_value(value($return));
my ($name, $args) = flat($name_args);
if (is_blank($args)) {
set_name_value($t, $name, $return_type);
}
else {
my $args_type = get_mylisp_atoms_value($args);
my $value = cons($args_type, $return_type);
set_name_value($t, $name, $value);
}
}
sub get_mylisp_atoms_value {
my $atoms = shift;
my $names = [map { value($_) } @{ atoms($atoms) }];
return join ' ', @{$names};
}
sub my_const {
my ($t, $args) = @_;
my ($sym, $value) = flat($args);
my $name = value($sym);
my $value_type = get_atom_type($t, $value);
set_name_value($t, $name, $value_type);
}
sub lint_mylisp_atoms {
my ($t, $atoms) = @_;
for my $atom (@{ atoms($atoms) }) {
lint_mylisp_atom($t, $atom);
}
}
sub lint_mylisp_atom {
my ($t, $atom) = @_;
my ($name, $args) = flat($atom);
update_pos($t, $atom);
given ($name) {
when ('func') { lint_mylisp_func($t, $args) }
when ('return') { lint_mylisp_return($t, $args) }
when ('my') { lint_mylisp_my($t, $args) }
when ('our') { lint_mylisp_our($t, $args) }
when ('=') { lint_mylisp_set($t, $args) }
when ('Sym') { lint_mylisp_sym($t, $args) }
when ('Aindex') { lint_mylisp_aindex($t, $args) }
when ('for') { lint_mylisp_for($t, $args) }
when ('while') { lint_mylisp_cond_atoms($t, $args) }
when ('given') { lint_mylisp_cond_atoms($t, $args) }
when ('when') { lint_mylisp_cond_atoms($t, $args) }
when ('then') { lint_mylisp_exprs($t, $args) }
when ('if') { lint_mylisp_cond_atoms($t, $args) }
when ('elif') { lint_mylisp_cond_atoms($t, $args) }
when ('else') { lint_mylisp_exprs($t, $args) }
when ('String') { lint_mylisp_atoms($t, $args) }
when ('Array') { lint_mylisp_atoms($t, $args) }
when ('Hash') { lint_mylisp_atoms($t, $args) }
when ('Pair') { lint_mylisp_atoms($t, $args) }
when ('end') { out_ns($t) }
when ('package') { return 1 }
when ('const') { return 1 }
when ('Str') { return 1 }
when ('Lstr') { return 1 }
when ('Int') { return 1 }
when ('Char') { return 1 }
when ('Bool') { return 1 }
when ('Type') { return 1 }
when ('Ns') { return 1 }
when ('use') { return 1 }
when ('import') { return 1 }
when ('->') { return 1 }
default { lint_mylisp_call($t, $name, $args) }
}
}
sub lint_mylisp_cond_atoms {
my ($t, $atoms) = @_;
my ($cond_atom, $exprs) = match($atoms);
lint_mylisp_atom($t, $cond_atom);
lint_mylisp_exprs($t, $exprs);
}
sub lint_mylisp_exprs {
my ($t, $exprs) = @_;
my $uuid = uuid();
in_ns($t, $uuid);
lint_mylisp_atoms($t, $exprs);
out_block($t, $uuid);
}
sub lint_mylisp_func {
my ($t, $args) = @_;
my ($name_args, $rest) = match($args);
my ($return, $atoms) = match($rest);
my $return_type_str = get_return_type_str($return);
$t->{'return'} = $return_type_str;
my ($call, $func_args) = flat($name_args);
in_ns($t, $call);
for my $arg (@{ atoms($func_args) }) {
my ($name, $type) = flat($arg);
set_name_value($t, $name, $type);
}
lint_mylisp_atoms($t, $atoms);
out_ns($t);
}
sub get_return_type_str {
my $expr = shift;
my $args = value($expr);
my $names = [map { value($_) } @{ atoms($args) }];
return join '', @{$names};
}
sub lint_mylisp_return {
my ($t, $args) = @_;
my $call = ns($t);
my $return_type = $t->{'return'};
my $args_type_str = get_atoms_type_str($t, $args);
my $args_pat = pat_to_type_rule($t, $args_type_str);
my $p = $t->{'parser'};
my $match = match_type($p, $args_pat, $return_type);
lint_mylisp_atoms($t, $args);
if (is_false($match)) {
say "return type is not same with call declare";
report($t, "$args_type_str != $return_type");
}
}
sub get_atoms_type_str {
my ($t, $atoms) = @_;
my $types = [];
for my $atom (@{ atoms($atoms) }) {
push @{$types}, get_atom_type($t, $atom);
}
return join ' ', @{$types};
}
sub lint_mylisp_my {
my ($t, $args) = @_;
my ($sym, $value) = flat($args);
lint_mylisp_atom($t, $value);
my $type = get_atom_type($t, $value);
my $name = value($sym);
if (is_str($type)) { set_name_value($t, $name, $type) }
else { report($t, "one sym accept more assign") }
}
sub lint_mylisp_our {
my ($t, $args) = @_;
my ($array, $value) = flat($args);
lint_mylisp_atom($t, $value);
my $type = get_atom_type($t, $value);
my $types = [split ' ', $type];
my $syms = value($array);
lint_mylisp_sym_list($t, $syms);
my ($a, $b) = flat($syms);
if (len($types) != 2) {
report($t, "return value not two");
}
my $a_name = value($a);
my $b_name = value($b);
my $a_type = $types->[0];
my $b_type = $types->[1];
set_name_value($t, $a_name, $a_type);
set_name_value($t, $b_name, $b_type);
}
sub lint_mylisp_call {
my ($t, $name, $args) = @_;
my $value = get_name_value($t, $name);
if (is_blank($args)) {
if (is_estr($value)) {
report($t, "call |$name| less argument");
}
return 1;
}
if (is_str($value)) {
report($t, "call |$name| more argument");
}
my $call_type_str = name($value);
lint_mylisp_atoms($t, $args);
my $args_type_str = get_args_type_str($t, $args);
my $p = $t->{'parser'};
my $call_rule = pat_to_type_rule($t, $call_type_str);
my $match = match_type($p, $call_rule, $args_type_str);
if (is_false($match)) {
say "$call_type_str != $args_type_str";
report($t, "call |$name| args type not same!");
}
}
sub get_args_type_str {
my ($t, $args) = @_;
my $type_strs = [];
for my $arg (@{ atoms($args) }) {
my $arg_type = get_atom_type($t, $arg);
push @{$type_strs}, $arg_type;
}
return join '', @{$type_strs};
}
sub lint_mylisp_for {
my ($t, $args) = @_;
my ($iter_expr, $exprs) = match($args);
my ($name, $iter_atom) = flat($iter_expr);
my $type = get_iter_type($t, $iter_atom);
set_name_value($t, $name, $type);
lint_mylisp_exprs($t, $exprs);
}
sub lint_mylisp_set {
my ($t, $args) = @_;
my ($sym, $value) = flat($args);
my $sym_type = get_atom_type($t, $sym);
my $value_type = get_atom_type($t, $value);
if ($sym_type ne $value_type) {
say "$sym_type != $value_type";
report($t, "assign type not same with define!");
}
}
sub lint_mylisp_sym_list {
my ($t, $list) = @_;
for my $sym (@{ atoms($list) }) {
next if is_sym($sym);
report($t, "Symbol List have no variable!");
}
}
sub lint_mylisp_sym {
my ($t, $name) = @_;
if (not(is_define($t, $name))) {
report($t, "not defined symbol: |$name|");
}
}
sub get_atom_type {
my ($t, $atom) = @_;
my ($name, $args) = flat($atom);
update_pos($t, $atom);
given ($name) {
when ('Type') { return $args }
when ('Int') { return $name }
when ('Str') { return $name }
when ('Bool') { return $name }
when ('Hash') { return $name }
when ('Char') { return 'Str' }
when ('Lstr') { return 'Str' }
when ('String') { return 'Str' }
when ('Ns') { return 'Ns' }
when ('Array') { return get_array_type($t, $args) }
when ('Aindex') { return get_aindex_type($t, $args) }
when ('Sym') { return get_sym_type($t, $args) }
when ('if') { report($t, "$name as argument") }
when ('elif') { report($t, "$name as argument") }
when ('else') { report($t, "$name as argument") }
when ('given') { report($t, "$name as argument") }
when ('when') { report($t, "$name as argument") }
when ('then') { report($t, "$name as argument") }
when ('func') { report($t, "$name as argument") }
when ('my') { report($t, "$name as argument") }
when ('our') { report($t, "$name as argument") }
when ('use') { report($t, "$name as argument") }
when ('import') { report($t, "$name as argument") }
when ('package') { report($t, "$name as argument") }
when ('const') { report($t, "$name as argument") }
when ('for') { report($t, "$name as argument") }
when ('while') { report($t, "$name as argument") }
when ('return') { report($t, "$name as argument") }
default { return get_call_type($t, $name, $args) }
}
}
sub get_sym_type {
my ($t, $args) = @_;
my $value = get_name_value($t, $args);
if (is_str($value)) { return $value }
return 'Fn';
}
sub get_call_type {
my ($t, $name, $args) = @_;
my $value = get_name_value($t, $name);
if (is_str($value)) { return $value }
return value($value);
}
sub get_array_type {
my ($t, $args) = @_;
if (is_blank($args)) { return 'Array' }
my $sub_type = get_atom_type($t, name($args));
if ($sub_type eq 'Int') { return 'Iarray' }
return 'Array';
}
sub get_arange_type {
my ($t, $args) = @_;
my $sym = name($args);
my $type = get_atom_type($t, $sym);
if ($type eq 'Array') { return $type }
report($t, "Not Array arange");
}
sub get_iter_type {
my ($t, $atom) = @_;
my $type = get_atom_type($t, $atom);
given ($type) {
when ('Array') { return 'Str' }
when ('Hash') { return 'Str' }
when ('Str') { return 'Str' }
when ('Iarray') { return 'Int' }
when ('Int+') { return 'Int' }
when ('Str+') { return 'Str' }
default { report($t, "|$type| could not index") }
}
}
sub lint_mylisp_aindex {
my ($t, $args) = @_;
lint_mylisp_atoms($t, $args);
}
sub get_aindex_type {
my ($t, $args) = @_;
my ($sym, $indexs) = match($args);
my $value = get_atom_type($t, $sym);
for my $index (@{ atoms($indexs) }) {
my $type = get_atom_type($t, $index);
my $name = value($index);
$value = get_index_type($t, $value, $type, $name);
}
return $value;
}
sub get_index_type {
my ($t, $value, $type, $name) = @_;
given ($value) {
when ('Array') {
if ($type eq 'Int') { return 'Str' }
report($t, "Array index is: $type")
}
when ('Iarray') {
if ($type eq 'Int') { return 'Int' }
report($t, "Iarray index is $type")
}
when ('Hash') {
if ($type eq 'Str') { return 'Str' }
report($t, "Hash index is: |$type|")
}
when ('Stable') {
if ($type eq 'Str') { return 'Hash' }
report($t, "StrHash index is: |$type|")
}
when ('Cursor') {
if ($type eq 'Str') {
given ($name) {
when ('code') { return 'Str' }
when ('ns') { return 'Hash' }
when ('off') { return 'Int' }
when ('depth') { return 'Int' }
when ('length') { return 'Int' }
when ('line') { return 'Int' }
when ('maxline') { return 'Int' }
when ('maxoff') { return 'Int' }
default { report($t, "Cursor !exists $name") }
}
}
report($t, "Cursor index is: |$type|")
}
when ('Lint') {
if ($type eq 'Str') {
given ($name) {
when ('code') { return 'Str' }
when ('offline') { return 'Str' }
when ('st') { return 'Stable' }
when ('stack') { return 'Array' }
when ('parser') { return 'Parser' }
when ('patter') { return 'Str' }
when ('return') { return 'Str' }
default { report($t, "Lint !exists $name") }
}
}
report($t, "Lint index is: |$type|")
}
when ('Parser') {
if ($type eq 'Str') {
given ($name) {
when ('str') { return 'Str' }
when ('off') { return 'Int' }
when ('ns') { return 'Hash' }
default { report($t, "Parser not exists $name") }
}
}
report($t, "Parser index is: |$type|")
}
default { report($t, "Could not index: $value") }
}
}
1;