package SExpression::Decode::Marpa;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2020-04-10'; # DATE
our $DIST = 'SExpression-Decode-Marpa'; # DIST
our $VERSION = '0.001'; # VERSION

use 5.010001;
use strict;
use warnings;

use MarpaX::Simple qw(gen_parser);

require Exporter;
our @ISA       = qw(Exporter);
our @EXPORT_OK = qw(from_sexp);

my $parser = gen_parser(
    grammar => <<'EOF',
:default         ::= action => do_array

:start           ::= value

value            ::= number_int_radix action => do_number_int_radix
                   | number_int_hex action => do_number_int_hex
                   | number_int_oct action => do_number_int_oct
                   | number_int_bin action => do_number_int_bin
                   | number_inf_nan action => do_number_inf_nan
                   | number_int action => do_first
                   | number_float action => do_first
                   | char_unescaped action => do_char_unescaped
                   | char_escaped_1char action => do_char_escaped_1char
                   | char_escaped_ctrl action => do_char_escaped_ctrl
                   | string action => do_first
                   | list action => do_first
                   | vector action => do_first
                   | 't' action => do_true
                   | 'nil' action => do_undef
                   | atom action => do_first

opt_dec_digits     ~ [0-9]*
dec_digits         ~ [0-9]+
hex_digits         ~ [0-9A-Fa-f]+
oct_digits         ~ [0-7]+
bin_digits         ~ [01]+
alphanums          ~ [0-9A-Za-z]+
sign               ~ [+-]
r                  ~ [rR]
x                  ~ [xX]
o                  ~ [oO]
b                  ~ [bB]
e                  ~ [eE]

number_int_radix   ~ '#' dec_digits r sign alphanums
                   | '#' dec_digits r      alphanums

number_int_hex     ~ '#' x sign hex_digits
                   | '#' x      hex_digits

number_int_oct     ~ '#' o sign oct_digits
                   | '#' o      oct_digits

number_int_bin     ~ '#' b sign bin_digits
                   | '#' b      bin_digits

number_int         ~ sign dec_digits
                   |      dec_digits

unsigned_decimal   ~ opt_dec_digits '.' dec_digits
                   | dec_digits '.' opt_dec_digits
decimal            ~ sign unsigned_decimal
                   |      unsigned_decimal
inf                ~ 'INF'
nan                ~ 'NaN'

number_inf_nan     ~ decimal e '+' inf
                   | decimal e '+' nan

exp                ~ e sign dec_digits
                   | e      dec_digits

number_float       ~ decimal
                   | decimal exp

ch1                ~ [^\\\(]
char_unescaped     ~ '?' ch1

ch2                ~ [^\^C]
char_escaped_1char ~ '?\' ch2

alpha              ~ [A-Za-z]
ch3                ~ 'C-'
                   | '^'
char_escaped_ctrl  ~ '?\' ch3 alpha

string           ::= string_lexeme action => do_string
string_lexeme      ~ quote in_string quote
quote              ~ ["]
in_string          ~ in_string_char*
in_string_char     ~ [^"\\]
                   | '\' [\d\D]

atom               ~ [^\\\[\]\(\)\s".#]+

vector           ::= ('[' ']')
                   | ('[') list_elems_dot   (']') action => do_first
                   | ('[') list_elems_nodot (']') action => do_first

list             ::= ('(' ')')
                   | ('(') list_elems_dot   (')') action => do_first
                   | ('(') list_elems_nodot (')') action => do_first

list_elems_nodot ::= value+
list_elems_dot   ::= list_elems_nodot ('.') value action => do_list_elems_dot

whitespace         ~ [\s]+
:discard           ~ whitespace

EOF
    actions => {
        do_array  => sub { shift; [@_] },
        do_join   => sub { shift; join "", @_ },
        do_hash   => sub { shift; +{map {@$_} @{ $_[0] } } },
        do_first  => sub { $_[1] },
        do_second => sub { $_[2] },
        do_number_int_radix => sub {
            require Math::NumberBase;

            my ($base, $num) = $_[1] =~ /\A#([0-9]+)[rR](\w+)/ or die;
            $_[1] =~ s/\A([+-]?)//;
            my $sign = $1 // '';
            ($sign eq '-' ? -1:1) * Math::NumberBase->new($base)->to_decimal(lc $num);
        },
        do_number_int_hex => sub {
            my $str = $_[1];
            $str =~ s/\A#[xX]//;
            $str =~ s/\A([+-]?)//;
            my $sign = $1 // '';
            ($sign eq '-' ? -1:1) * hex($str);
        },
        do_number_int_oct => sub {
            my $str = $_[1];
            $str =~ s/\A#[oO]//;
            $str =~ s/\A([+-]?)//;
            my $sign = $1 // '';
            ($sign eq '-' ? -1:1) * oct($str);
        },
        do_number_int_bin => sub {
            my $str = $_[1];
            $str =~ s/\A#[bB]//;
            $str =~ s/\A([+-]?)//;
            my $sign = $1 // '';
            ($sign eq '-' ? -1:1) * oct("0b$str");
        },
        do_number_inf_nan => sub {
            my $str = $_[1];
            $str =~ s/\A([+-]?)//;
            my $sign = $1 // '';
            $str =~ /NaN/ ? "NaN" : ($sign eq '-' ? -1:1) * "Inf";
        },
        do_char_unescaped => sub {
            substr($_[1], -1, 1);
        },
        do_char_escaped_1char => sub {
            my $char = substr($_[1], -1, 1);
            if    ($char eq 'a') { return chr(7) }
            elsif ($char eq 'b') { return chr(8) }
            elsif ($char eq 't') { return chr(9) }
            elsif ($char eq 'n') { return chr(10) }
            elsif ($char eq 'v') { return chr(11) }
            elsif ($char eq 'f') { return chr(12) }
            elsif ($char eq 'r') { return chr(13) }
            elsif ($char eq 'e') { return chr(27) }
            elsif ($char eq 's') { return chr(32) }
            elsif ($char eq 'd') { return chr(127) }
            else { return $char }
        },
        do_char_escaped_ctrl => sub {
            my $char = lc substr($_[1], -1, 1);
            return chr(ord($char) - 97+1);
        },
        do_string => sub {
            my $str0 = substr($_[1], 1, length($_[1])-2);
            $str0 =~ s{\\(C-|^)([A-Za-z]) | \\([^C\^])}
                      {
                          if ($1) { chr(ord(lc $2) - 97+1) }
                          else    {
                              if    ($3 eq 'a') { return chr(7) }
                              elsif ($3 eq 'b') { return chr(8) }
                              elsif ($3 eq 't') { return chr(9) }
                              elsif ($3 eq 'n') { return chr(10) }
                              elsif ($3 eq 'v') { return chr(11) }
                              elsif ($3 eq 'f') { return chr(12) }
                              elsif ($3 eq 'r') { return chr(13) }
                              elsif ($3 eq 'e') { return chr(27) }
                              elsif ($3 eq 's') { return chr(32) }
                              elsif ($3 eq 'd') { return chr(127) }
                              else { $3 }
                          }
                      }egx;
            $str0;
        },
        do_list_elems_dot  => sub { [@{ $_[1] }, $_[2]] },
        do_undef  => sub { undef },
        do_true   => sub { 1 },
        do_empty_string => sub { '' },
    },
);

sub from_sexp {
    $parser->(shift);
}

1;
# ABSTRACT: S-expression parser using Marpa

__END__

=pod

=encoding UTF-8

=head1 NAME

SExpression::Decode::Marpa - S-expression parser using Marpa

=head1 VERSION

This document describes version 0.001 of SExpression::Decode::Marpa (from Perl distribution SExpression-Decode-Marpa), released on 2020-04-10.

=head1 SYNOPSIS

 use SExpression::Decode::Marpa qw(from_sexp);
 my $data = from_sexp(q|((foo . 1) (bar . 2))|); # => [[foo=>1], [bar=>2]]

=head1 DESCRIPTION

B<EARLY RELEASE.>

Todo: wrap special values (e.g. nil, t, keyword symbol :foo, other symbols,
vectors, lists). Convert to alist when appropriate.

=head1 FUNCTIONS

=head2 from_sexp

Usage:

 my $data = from_sexp($str);

Decode S-expresion in C<$str>. Dies on error.

=head1 FAQ

=head1 HOMEPAGE

Please visit the project's homepage at L<https://metacpan.org/release/SExpression-Decode-Marpa>.

=head1 SOURCE

Source repository is at L<https://github.com/perlancar/perl-SExpression-Decode-Marpa>.

=head1 BUGS

Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=SExpression-Decode-Marpa>

When submitting a bug or request, please include a test-file or a
patch to an existing test-file that illustrates the bug or desired
feature.

=head1 SEE ALSO

L<Data::SExpression>, another S-expression parser based on L<Parse::Yapp>.

L<SExpression::Decode::Regexp>

=head1 AUTHOR

perlancar <perlancar@cpan.org>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2020 by perlancar@cpan.org.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut
