File Coverage

blib/lib/Mylisp/ToGo.pm

Criterion	Covered	Total	%
statement	14	380	3.6
branch	0	26	0.0
condition			n/a
subroutine	5	44	11.3
pod	0	39	0.0
total	19	489	3.8

package Mylisp::ToGo;

use 5.012;
no warnings "experimental";

use Exporter;
our @ISA = qw(Exporter);
our @EXPORT =
  qw(ast_to_go atoms_to_go join_go_exprs atoms_to_gos atom_to_go not_to_go oper_to_go call_to_go my_to_go const_to_go our_to_go slist_to_go array_to_go package_to_go use_to_go ns_to_go func_to_go name_args_to_go arg_to_go return_expr_to_go for_to_go iter_to_go while_to_go if_to_go elif_to_go else_to_go cond_expr_to_go given_to_go when_to_go then_to_go aindex_to_go lstr_to_go str_to_go string_to_go return_to_go name_to_go sym_to_go type_to_go type_declare_to_go);
use Spp::Builtin;
use Spp::Tools;
sub ast_to_go { my $ast = shift; return atoms_to_go($ast) }

sub atoms_to_go {
  my $atoms = shift;
  my $strs = [map { atom_to_go($_) } @{ atoms($atoms) }];
  return join_go_exprs($strs);
}

sub join_go_exprs {
  my $exprs = shift;
  my $strs  = [];
  my $count = 0;
  for my $expr (@{$exprs}) {
    $count++;
    if ($count == 1) { push @{$strs}, $expr; }
    else {
      if (not(start_with($expr, 'else'))) {
        push @{$strs}, ';';
      }
      push @{$strs}, $expr;
    }
  }
  return join '', @{$strs};
}

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

sub atom_to_go {
  my $atom = shift;
  my ($name, $args) = flat($atom);
  given ($name) {
    when ('package') { return package_to_go($args) }
    when ('use')     { return use_to_go($args) }
    when ('func')    { return func_to_go($args) }
    when ('given')   { return given_to_go($args) }
    when ('for')     { return for_to_go($args) }
    when ('while')   { return while_to_go($args) }
    when ('if')      { return if_to_go($args) }
    when ('elif')    { return elif_to_go($args) }
    when ('else')    { return else_to_go($args) }
    when ('given')   { return given_to_go($args) }
    when ('when')    { return when_to_go($args) }
    when ('then')    { return then_to_go($args) }
    when ('return')  { return return_to_go($args) }
    when ('my')      { return my_to_go($args) }
    when ('our')     { return our_to_go($args) }
    when ('const')   { return const_to_go($args) }
    when ('not')     { return not_to_go($args) }
    when ('Aindex')  { return aindex_to_go($args) }
    when ('Sym')     { return sym_to_go($args) }
    when ('Lstr')    { return lstr_to_go($args) }
    when ('Str')     { return str_to_go($args) }
    when ('String')  { return string_to_go($args) }
    when ('Array')   { return array_to_go($args) }
    when ('Type')    { return type_to_go($args) }
    when ('Int')     { return $args }
    when ('Bool')    { return $args }
    when ('end')     { return ' ' }
    default {
      my $strs = atoms_to_gos($args);
      return oper_to_go($name, $strs)
    }
  }
}

sub not_to_go {
  my $args = shift;
  my $str  = atoms_to_go($args);
  return "!$str";
}

sub oper_to_go {
  my ($name, $strs) = @_;
  given ($name) {
    when ('gt')  { return ejoin($strs, '>') }
    when ('ge')  { return ejoin($strs, '>=') }
    when ('lt')  { return ejoin($strs, '<') }
    when ('eq')  { return ejoin($strs, '==') }
    when ('le')  { return ejoin($strs, '<=') }
    when ('ne')  { return ejoin($strs, '!=') }
    when ('add') { return ejoin($strs, '+') }
    when ('=')   { return ejoin($strs, '=') }
    when ('+')   { return ejoin($strs, '+') }
    when ('-')   { return ejoin($strs, '-') }
    when ('==')  { return ejoin($strs, '==') }
    when ('>=')  { return ejoin($strs, '>=') }
    when ('!=')  { return ejoin($strs, '!=') }
    when ('>')   { return ejoin($strs, '>') }
    when ('<')   { return ejoin($strs, '<') }
    when ('<=')  { return ejoin($strs, '<=') }
    when ('&&')  { return ejoin($strs, '&&') }
    when ('||')  { return ejoin($strs, '||') }
    default { return call_to_go($name, $strs) }
  }
}

sub call_to_go {
  my ($name, $strs) = @_;
  my $args_str = ejoin($strs, ',');
  given ($name) {
    when ('~~')     { return call_to_go('is-in',    $strs) }
    when ('>>')     { return call_to_go('eunshift', $strs) }
    when ('<<')     { return call_to_go('epush',    $strs) }
    when ('><')     { return call_to_go('eappend',  $strs) }
    when ('length') { return call_to_go('len',      $strs) }
    when ('exitif') { return "if $args_str { Exit() }" }
    when ('nextif') { return "if $args_str { continue }" }
    default {
      $name = sym_to_go($name);
      return "$name($args_str)"
    }
  }
}

sub my_to_go {
  my $args = shift;
  my $strs = atoms_to_gos($args);
  my ($sym, $value) = flat($strs);
  return "$sym := $value";
}

sub const_to_go {
  my $args = shift;
  my $strs = atoms_to_gos($args);
  my ($sym, $value) = flat($strs);
  return "const $sym = $value";
}

sub our_to_go {
  my $args = shift;
  my ($slist, $value) = flat($args);
  my $slist_str = slist_to_go(value($slist));
  my $value_str = atom_to_go($value);
  return "$slist_str := $value_str";
}

sub slist_to_go {
  my $syms  = shift;
  my $names = atoms_to_gos($syms);
  return ejoin($names, ',');
}

sub array_to_go {
  my $args = shift;
  my $strs = atoms_to_gos($args);
  my $str  = ejoin($strs, ',');
  return "Array{$str}";
}

sub package_to_go {
  my $ns   = shift;
  my $name = ns_to_go($ns);
  return "package $name";
}

sub use_to_go {
  my $ns    = shift;
  my $names = [split '::', $ns];
  my $name  = join '/', @{$names};
  return "import . \"$name\"";
}

sub ns_to_go {
  my $ns = shift;
  return tail([split '::', $ns]);
}

sub func_to_go {
  my $args = shift;
  my ($name_args, $rest)  = match($args);
  my ($return,    $exprs) = match($rest);
  my $args_str   = name_args_to_go($name_args);
  my $return_str = return_expr_to_go($return);
  my $exprs_str  = atoms_to_go($exprs);
  if ($return_str eq 'Null') {
    return "func $args_str { $exprs_str }";
  }
  return "func $args_str $return_str { $exprs_str }";
}

sub name_args_to_go {
  my $name_args = shift;
  my ($name, $args) = flat($name_args);
  my $args_str = join ',',
    @{ [map { arg_to_go($_) } @{ atoms($args) }] };
  $name = sym_to_go($name);
  return "$name($args_str)";
}

sub arg_to_go {
  my $arg = shift;
  my ($name, $type) = flat($arg);
  my $name_str = name_to_go($name);
  return "$name_str $type";
}

sub return_expr_to_go {
  my $expr     = shift;
  my $args     = value($expr);
  my $types    = [map { value($_) } @{ atoms($args) }];
  my $go_types = [map { type_declare_to_go($_) } @{$types}];
  my $str      = join ',', @{$go_types};
  if (len($types) == 1) { return $str }
  return "($str)";
}

sub for_to_go {
  my $args = shift;
  my ($iter_atom, $exprs) = match($args);
  my $iter_str  = iter_to_go($iter_atom);
  my $exprs_str = atoms_to_go($exprs);
  return "for $iter_str $exprs_str }";
}

sub iter_to_go {
  my $atom = shift;
  my ($loop_name, $iter_atom) = flat($atom);
  my $loop = sym_to_go($loop_name);
  my $iter = atom_to_go($iter_atom);
  if (is_sym($iter_atom)) {
    my $char = first_char(value($iter_atom));
    given ($char) {
      when ('$') {
        return "_, c := range $iter { $loop := string(c);"
      }
      when ('%') { return "$loop, _ := range $iter { " }
      default    { return "_, $loop := range $iter { " }
    }
  }
  return "_, $loop := range $iter { ";
}

sub while_to_go {
  my $args = shift;
  my ($guide_atom, $exprs) = match($args);
  my $guide_str = atom_to_go($guide_atom);
  my $exprs_str = atoms_to_go($exprs);
  return "for $guide_str { $exprs_str }";
}

sub if_to_go {
  my $args     = shift;
  my $args_str = cond_expr_to_go($args);
  return "if $args_str";
}

sub elif_to_go {
  my $args     = shift;
  my $args_str = cond_expr_to_go($args);
  return "else if $args_str";
}

sub else_to_go {
  my $args     = shift;
  my $args_str = atoms_to_go($args);
  return "else { $args_str }";
}

sub cond_expr_to_go {
  my $args = shift;
  my ($cond_atom, $exprs) = match($args);
  my $cond_str  = atom_to_go($cond_atom);
  my $exprs_str = atoms_to_go($exprs);
  return "$cond_str { $exprs_str }";
}

sub given_to_go {
  my $args = shift;
  my $str  = cond_expr_to_go($args);
  return "switch $str";
}

sub when_to_go {
  my $args = shift;
  my ($cond_atom, $exprs) = match($args);
  my $cond_str  = atom_to_go($cond_atom);
  my $exprs_str = atoms_to_go($exprs);
  return "case $cond_str: $exprs_str";
}

sub then_to_go {
  my $args     = shift;
  my $args_str = atoms_to_go($args);
  return "default: $args_str";
}

sub aindex_to_go {
  my $args = shift;
  my $strs = atoms_to_gos($args);
  my ($sym, $indexs) = match($strs);
  my $index_str = ejoin($indexs, '][');
  return "$sym\[$index_str]";
}
sub lstr_to_go { my $args = shift; return "`$args`" }
sub str_to_go  { my $str  = shift; return "`$str`" }

sub string_to_go {
  my $args  = shift;
  my $chars = [];
  my $syms  = [];
  for my $atom (@{ atoms($args) }) {
    if (is_sym($atom)) {
      push @{$chars}, '%s';
      push @{$syms},  atom_to_go($atom);
    }
    else { push @{$chars}, value($atom); }
  }
  my $str_expr = join '', @{$chars};
  if (len($syms) > 0) {
    my $syms_str = join ',', @{$syms};
    return "Sprintf(\"$str_expr\", $syms_str)";
  }
  return "\"$str_expr\"";
}

sub return_to_go {
  my $args = shift;
  my $strs = [map { atom_to_go($_) } @{ atoms($args) }];
  my $str  = join ',', @{$strs};
  return "return $str";
}

sub name_to_go {
  my $name  = shift;
  my $chars = [];
  for my $char (split '', $name) {
    if   (is_alpha($char)) { push @{$chars}, $char; }
    else                   { push @{$chars}, '_'; }
  }
  return join '', @{$chars};
}

sub sym_to_go {
  my $name       = shift;
  my $first_char = first_char($name);
  if ($first_char ~~ ['$', '@', '%']) {
    return name_to_go($name);
  }
  if ($name ~~ ['len', 'append']) { return $name }
  my $chars = [];
  my $mode  = 0;
  for my $char (split '', $name) {
    next if $char eq '$';
    if ($mode == 0) {
      $mode = 1;
      push @{$chars}, uc($char);
    }
    else {
      if ($char eq '-') { $mode = 0 }
      else              { push @{$chars}, $char; }
    }
  }
  return join '', @{$chars};
}

sub type_to_go {
  my $str = shift;
  given ($str) {
    when ('Str')   { return 'Str' }
    when ('Int')   { return 'Int' }
    when ('Bool')  { return 'Bool' }
    when ('Array') { return 'Array{}' }
    when ('Hash')  { return 'Hash{}' }
  }
}

sub type_declare_to_go {
  my $str = shift;
  given ($str) {
    when ('Str')    { return 'Str' }
    when ('Str+')   { return '...Str' }
    when ('Str?')   { return 'Str' }
    when ('Int')    { return 'Int' }
    when ('Bool')   { return 'Bool' }
    when ('Array')  { return 'Array' }
    when ('Hash')   { return 'Hash' }
    when ('Null')   { return 'Null' }
    when ('Cursor') { return '*Cursor' }
    when ('Lint')   { return '*Lint' }
    when ('Parser') { return '*Parser' }
    default         { return "*$str" }
  }
}
1;