File Coverage

blib/lib/Mylisp/ToMylisp.pm

Criterion	Covered	Total	%
statement	14	173	8.0
branch	0	18	0.0
condition			n/a
subroutine	5	22	22.7
pod	0	17	0.0
total	19	230	8.2

package Mylisp::ToMylisp;

use 5.012;
no warnings "experimental";

use Exporter;
our @ISA = qw(Exporter);
our @EXPORT =
  qw(ast_to_mylisp atoms_to_mylisp atoms_to_mylisps atom_to_mylisp oper_to_mylisp name_to_mylisp func_to_mylisp args_to_mylisp aindex_to_mylisp for_to_mylisp our_to_mylisp str_to_mylisp string_to_mylisp array_to_mylisp hash_to_mylisp is_kstr tidy_mylisp);
use Spp::Builtin;
use Spp::Tools;

sub ast_to_mylisp {
  my $ast = shift;
  my $str = atoms_to_mylisp($ast);
  return tidy_mylisp($str);
}

sub atoms_to_mylisp {
  my $atoms = shift;
  my $strs =
    [map { atom_to_mylisp($_) } @{ atoms($atoms) }];
  return join ' ', @{$strs};
}

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

sub atom_to_mylisp {
  my $atom = shift;
  my ($name, $args) = flat($atom);
  if (
    $name ~~ [
      '!=', '&&', '+',  '-',  '<',  '<<', '<=', '==',
      '>',  '=',  '>=', '>>', '><', 'eq', 'in', 'le',
      'ne', 'x',  '||'
    ]
    )
  {
    return oper_to_mylisp($name, $args);
  }
  given ($name) {
    when ('func')    { return func_to_mylisp($args) }
    when ('Aindex')  { return aindex_to_mylisp($args) }
    when ('Str')     { return str_to_mylisp($args) }
    when ('String')  { return string_to_mylisp($args) }
    when ('Array')   { return array_to_mylisp($args) }
    when ('Hash')    { return hash_to_mylisp($args) }
    when ('for')     { return for_to_mylisp($args) }
    when ('our')     { return our_to_mylisp($args) }
    when ('package') { return "(package $args)" }
    when ('use')     { return "(use $args)" }
    when ('Sym')     { return $args }
    when ('Int')     { return $args }
    when ('Ns')      { return $args }
    when ('Bool')    { return $args }
    when ('Char')    { return $args }
    when ('Type')    { return $args }
    when ('end')     { return '(end)' }
    default { return name_to_mylisp($name, $args) }
  }
}

sub oper_to_mylisp {
  my ($name, $args) = @_;
  my $strs = atoms_to_mylisps($args);
  my $str = ejoin($strs, " $name ");
  return "($str)";
}

sub name_to_mylisp {
  my ($name, $args) = @_;
  my $str = atoms_to_mylisp($args);
  return "($name $str)";
}

sub func_to_mylisp {
  my $atoms = shift;
  my ($name_args, $exprs) = match($atoms);
  my ($name,      $args)  = flat($name_args);
  my $args_str  = args_to_mylisp($args);
  my $exprs_str = atoms_to_mylisp($exprs);
  return "(func ($name $args_str) $exprs_str)";
}

sub args_to_mylisp {
  my $args = shift;
  my $strs = [];
  for my $arg (@{ atoms($args) }) {
    my ($name, $type) = flat($arg);
    push @{$strs}, "$name:$type";
  }
  return join ' ', @{$strs};
}

sub aindex_to_mylisp {
  my $args = shift;
  my $strs = atoms_to_mylisps($args);
  my ($name, $indexs) = match($strs);
  my $indexs_str = ejoin($indexs, '][');
  return "$name\[$indexs_str]";
}

sub for_to_mylisp {
  my $args = shift;
  my ($iter_expr, $exprs)     = match($args);
  my ($loop,      $iter_atom) = flat($iter_expr);
  my $iter_str  = atom_to_mylisp($iter_atom);
  my $exprs_str = atoms_to_mylisp($exprs);
  return "(for ($loop in $iter_str) $exprs_str)";
}

sub our_to_mylisp {
  my $args = shift;
  my $strs = atoms_to_mylisps($args);
  my ($slist, $value) = flat($strs);
  return "(my $slist $value)";
}

sub str_to_mylisp {
  my $str = shift;
  if (is_kstr($str)) { return ":$str" }
  return "'$str'";
}

sub string_to_mylisp {
  my $string = shift;
  my $strs   = [map { value($_) } @{ atoms($string) }];
  my $str    = join '', @{$strs};
  return "\"$str\"";
}

sub array_to_mylisp {
  my $array     = shift;
  my $atoms     = atoms_to_mylisps($array);
  my $atoms_str = ejoin($atoms, ' ');
  return "[$atoms_str]";
}

sub hash_to_mylisp {
  my $pairs      = shift;
  my $pairs_strs = [];
  for my $pair (@{ atoms($pairs) }) {
    my ($name, $key_value) = flat($pair);
    my $pair_strs = atoms_to_mylisps($key_value);
    my ($key, $value) = flat($pair_strs);
    push @{$pairs_strs}, "$key => $value";
  }
  my $pairs_str = join ', ', @{$pairs_strs};
  return "{$pairs_str}";
}

sub is_kstr {
  my $str = shift;
  for my $char (split '', $str) {
    next if is_alpha($char);
    return 0;
  }
  return 1;
}

sub tidy_mylisp {
  my $str   = shift;
  my $chars = [];
  my $depth = 0;
  my $mode  = 'expr';
  for my $char (split '', $str) {
    if ($mode eq 'expr') {
      given ($char) {
        when ('(') { $depth++ }
        when (')') { $depth-- }
        when ("'") { $mode = 'str' }
        when ('"') { $mode = 'string' }
      }
    }
    if ($mode eq 'string') {
      when ('"')  { $mode = 'expr' }
      when ('\\') { $mode = 'stringescape' }
    }
    if ($mode eq 'str') {
      when ("'")  { $mode = 'expr' }
      when ('\\') { $mode = 'strescape' }
    }
    if ($mode eq 'stringescape') { $mode = 'string' }
    if ($mode eq 'strescape')    { $mode = 'str' }
    push @{$chars}, $char;
    if ($depth == 0) { push @{$chars}, "\n"; }
  }
  return join '', @{$chars};
}
1;