File Coverage

blib/lib/Mylisp/OptAst.pm

Criterion	Covered	Total	%
statement	14	246	5.6
branch	0	16	0.0
condition	0	3	0.0
subroutine	5	34	14.7
pod	0	29	0.0
total	19	328	5.7

package Mylisp::OptAst;

use 5.012;
no warnings "experimental";

use Exporter;
our @ISA = qw(Exporter);
our @EXPORT =
  qw(opt_mylisp_ast opt_mylisp_atoms opt_mylisp_atom opt_mylisp_expr is_oper opt_mylisp_infix_op_expr opt_mylisp_oper opt_mylisp_sub opt_mylisp_package opt_mylisp_use opt_mylisp_func opt_mylisp_func_args opt_mylisp_arg opt_mylisp_for opt_mylisp_iter opt_mylisp_my opt_mylisp_ocall_expr opt_mylisp_ocall opt_mylisp_name_value opt_mylisp_array opt_mylisp_hash opt_mylisp_pair opt_mylisp_aindex opt_mylisp_arange opt_mylisp_string opt_mylisp_str opt_mylisp_lstr opt_mylisp_kstr opt_mylisp_sym);
use Spp::Builtin;
use Spp::Tools;

sub opt_mylisp_ast {
  my $ast = shift;
  if (is_atom($ast)) { return cons(opt_mylisp_atom($ast)) }
  return opt_mylisp_atoms($ast);
}

sub opt_mylisp_atoms {
  my $atoms = shift;
  return estr(
    [map { opt_mylisp_atom($_) } @{ atoms($atoms) }]);
}

sub opt_mylisp_atom {
  my $atom = shift;
  my ($name, $rest) = match($atom);
  given ($name) {
    when ('Expr')   { return opt_mylisp_expr($rest) }
    when ('Ocall')  { return opt_mylisp_ocall($rest) }
    when ('Array')  { return opt_mylisp_array($rest) }
    when ('Hash')   { return opt_mylisp_hash($rest) }
    when ('Pair')   { return opt_mylisp_pair($rest) }
    when ('Aindex') { return opt_mylisp_aindex($rest) }
    when ('Arange') { return opt_mylisp_arange($rest) }
    when ('String') { return opt_mylisp_string($rest) }
    when ('Str')    { return opt_mylisp_str($rest) }
    when ('Lstr')   { return opt_mylisp_lstr($rest) }
    when ('Kstr')   { return opt_mylisp_kstr($rest) }
    when ('Sub')    { return opt_mylisp_sym($rest) }
    when ('Chars')  { return eunshift('Str', $rest) }
    when ('Var')    { return opt_mylisp_sym($rest) }
    when ('Scalar') { return opt_mylisp_sym($rest) }
    when ('Oper')   { return opt_mylisp_sym($rest) }
    when ('Char')   { return $atom }
    when ('Ns')     { return $atom }
    when ('Arg')    { return $atom }
    when ('Int')    { return $atom }
    default { error("unknown atom |$name| to opt!") }
  }
}

sub opt_mylisp_expr {
  my $value = shift;
  my ($expr, $pos) = flat($value);
  if (elen($expr) == 3 && is_oper(value($expr))) {
    return opt_mylisp_infix_op_expr($expr, $pos);
  }
  my ($first, $args) = match($expr);
  my ($type,  $name) = flat($first);
  given ($type) {
    when ('Sub') {
      return opt_mylisp_sub($name, $args, $pos)
    }
    when ('Oper') {
      return opt_mylisp_oper($name, $args, $pos)
    }
    when ('Ocall') {
      return opt_mylisp_ocall_expr($name, $args, $pos)
    }
    default {
      my $atoms = opt_mylisp_atoms($expr);
      return cons('Array', $atoms)
    }
  }
}

sub is_oper {
  my $atom = shift;
  if (is_atom($atom)) {
    my ($name, $value) = flat($atom);
    if ($name eq 'Oper') { return 1 }
    if ($value ~~ ['x', 'eq', 'le', 'ne', 'in']) {
      return 1;
    }
  }
  return 0;
}

sub opt_mylisp_infix_op_expr {
  my ($expr, $pos) = @_;
  my $atoms = atoms($expr);
  my $name  = value($atoms->[1]);
  my $args  = cons($atoms->[0], $atoms->[2]);
  $args = opt_mylisp_atoms($args);
  given ($name) {
    when ('>>') { return cons('eunshift', $args, $pos) }
    when ('<<') { return cons('epush',    $args, $pos) }
    when ('><') { return cons('eappend',  $args, $pos) }
    default     { return cons($name,      $args, $pos) }
  }
}

sub opt_mylisp_oper {
  my ($name, $args, $pos) = @_;
  my $atoms = opt_mylisp_atoms($args);
  return cons($name, $atoms, $pos);
}

sub opt_mylisp_sub {
  my ($name, $args, $pos) = @_;
  given ($name) {
    when ('package') {
      return opt_mylisp_package($args, $pos)
    }
    when ('use') { return opt_mylisp_use($args, $pos) }
    when ('func') { return opt_mylisp_func($args, $pos) }
    when ('for') { return opt_mylisp_for($args, $pos) }
    when ('my') { return opt_mylisp_my($args, $pos) }
    default {
      return cons($name, opt_mylisp_atoms($args), $pos)
    }
  }
}

sub opt_mylisp_package {
  my ($args, $pos) = @_;
  my $ns = value(name($args));
  return cons('package', $ns, $pos);
}

sub opt_mylisp_use {
  my ($args, $pos) = @_;
  my $atoms = opt_mylisp_atoms($args);
  my $ns    = value(name($atoms));
  return cons('use', $ns, $pos);
}

sub opt_mylisp_func {
  my ($args, $pos) = @_;
  my $atoms = opt_mylisp_atoms($args);
  my ($name_args, $exprs) = match($atoms);
  my $return = name($exprs);
  if (not(is_atom_name($return, '->'))) {
    my $line = value(offline($return));
    say "line: $line func less return expr!";
  }
  my $opt_args = opt_mylisp_func_args($name_args);
  my $func_exprs = eunshift($opt_args, $exprs);
  return cons('func', $func_exprs, $pos);
}

sub opt_mylisp_func_args {
  my $expr = shift;
  my ($call, $args) = flat($expr);
  my $opt_args =
    [map { opt_mylisp_arg($_) } @{ atoms($args) }];
  my $pos = offline($expr);
  return cons($call, $opt_args, $pos);
}

sub opt_mylisp_arg {
  my $arg = shift;
  if (is_atom_name($arg, 'Arg')) {
    my $arg_name = value($arg);
    my $names    = [split ':', $arg_name];
    my $name     = $names->[0];
    my $type     = $names->[1];
    my $pos      = offline($arg);
    return cons($name, $type, $pos);
  }
  my $line = value(offline($arg));
  say "line: $line func arg less type info!";
}

sub opt_mylisp_for {
  my ($args, $pos) = @_;
  my $atoms = opt_mylisp_atoms($args);
  my ($iter_expr, $rest) = match($atoms);
  my $iter_atom = opt_mylisp_iter($iter_expr);
  my $exprs = eunshift($iter_atom, $rest);
  return cons('for', $exprs, $pos);
}

sub opt_mylisp_iter {
  my $expr = shift;
  my ($in,       $args)      = flat($expr);
  my ($loop_sym, $iter_atom) = flat($args);
  my $loop = value($loop_sym);
  my $pos  = offline($expr);
  return cons($loop, $iter_atom, $pos);
}

sub opt_mylisp_my {
  my ($args, $pos) = @_;
  my $atoms = opt_mylisp_atoms($args);
  my $sym   = name($atoms);
  if (is_sym($sym)) { return cons('my', $atoms, $pos) }
  return cons('our', $atoms, $pos);
}

sub opt_mylisp_ocall_expr {
  my ($ocall, $args, $pos) = @_;
  my ($sym, $call) = flat($ocall);
  my $name = value($call);
  my $opt_args = opt_mylisp_atoms(eunshift($sym, $args));
  return cons($name, $opt_args, $pos);
}

sub opt_mylisp_ocall {
  my $value = shift;
  my ($args, $pos) = flat($value);
  my $opt_args = opt_mylisp_atoms($args);
  my ($sym, $call) = flat($opt_args);
  my $name = value($call);
  return cons($name, cons($sym), $pos);
}

sub opt_mylisp_name_value {
  my ($name, $value) = @_;
  my ($args, $pos)   = flat($value);
  my $atoms = opt_mylisp_atoms($args);
  return cons($name, $atoms, $pos);
}

sub opt_mylisp_array {
  my $value = shift;
  return opt_mylisp_name_value('Array', $value);
}

sub opt_mylisp_hash {
  my $value = shift;
  return opt_mylisp_name_value('Hash', $value);
}

sub opt_mylisp_pair {
  my $value = shift;
  return opt_mylisp_name_value('Pair', $value);
}

sub opt_mylisp_aindex {
  my $value = shift;
  return opt_mylisp_name_value('Aindex', $value);
}

sub opt_mylisp_arange {
  my $value = shift;
  return opt_mylisp_name_value('subarray', $value);
}

sub opt_mylisp_string {
  my $value = shift;
  return opt_mylisp_name_value('String', $value);
}

sub opt_mylisp_str {
  my $value = shift;
  my ($str, $pos) = flat($value);
  $str = substr($str, 1, -1);
  return cons('Str', $str, $pos);
}

sub opt_mylisp_lstr {
  my $value = shift;
  my ($lstr, $pos) = flat($value);
  my $str = substr($lstr, 3, -3);
  return cons('Lstr', $str, $pos);
}

sub opt_mylisp_kstr {
  my $value = shift;
  my ($kstr, $pos) = flat($value);
  my $str = substr($kstr, 1);
  return cons('Str', $str, $pos);
}

sub opt_mylisp_sym {
  my $value = shift;
  my ($name, $pos) = flat($value);
  given ($name) {
    when ('false')  { return cons('Bool', $name, $pos) }
    when ('true')   { return cons('Bool', $name, $pos) }
    when ('Null')   { return cons('Type', $name, $pos) }
    when ('Str')    { return cons('Type', $name, $pos) }
    when ('Int')    { return cons('Type', $name, $pos) }
    when ('Hash')   { return cons('Type', $name, $pos) }
    when ('Bool')   { return cons('Type', $name, $pos) }
    when ('Array')  { return cons('Type', $name, $pos) }
    when ('Stack')  { return cons('Type', $name, $pos) }
    when ('Iarray') { return cons('Type', $name, $pos) }
    when ('Stable') { return cons('Type', $name, $pos) }
    when ('Cursor') { return cons('Type', $name, $pos) }
    when ('Lint')   { return cons('Type', $name, $pos) }
    when ('Parser') { return cons('Type', $name, $pos) }
    default         { return cons('Sym',  $name, $pos) }
  }
}
1;