File Coverage

blib/lib/Mylisp/Type.pm

Criterion	Covered	Total	%
statement	29	267	10.8
branch	0	38	0.0
condition			n/a
subroutine	10	41	24.3
pod	0	31	0.0
total	39	377	10.3

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;