File Coverage

blib/lib/Mylisp/LintAst.pm

Criterion	Covered	Total	%
statement	29	477	6.0
branch	0	48	0.0
condition			n/a
subroutine	10	43	23.2
pod	0	33	0.0
total	39	601	6.4

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;