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;