#!/usr/bin/perl

use utf8;
use 5.014;

BEGIN {    # support for running sidef locally from everywhere
    require File::Spec;
    require File::Basename;
    unshift @INC,
      File::Spec->catdir(
                         File::Basename::dirname(
                                                   File::Spec->file_name_is_absolute(__FILE__)
                                                 ? __FILE__
                                                 : File::Spec->rel2abs(__FILE__)
                                                ),
                         File::Spec->updir,
                         'lib'
                        );
}

binmode STDIN,  ":utf8";
binmode STDOUT, ":utf8";
binmode STDERR, ":utf8" if $^P == 0;    # to work under Devel::* modules

use Sidef;

my $name    = 'Sidef';
my $version = $Sidef::VERSION;

sub NATIVE () { 0 }

my %args;
if ($#ARGV != -1 and chr ord $ARGV[0] eq '-') {
    require Getopt::Std;
    Getopt::Std::getopts('e:E:Dho:ivHWwbcrR:ts:CO:kP:M:', \%args);
}

# Help
if (defined $args{h}) {
    output_usage();
    exit 0;
}

# Version
if (defined $args{v}) {
    output_version();
    exit 0;
}

# Warnings
if (defined $args{w}) {
    $SIG{__WARN__} = sub {
        require Carp;
        Carp::cluck(@_);
    };
}
elsif (defined $args{W}) {
    $SIG{__DIE__} = $SIG{__WARN__} = sub {
        require Carp;
        Carp::confess(@_);
    };
}

# Number of spaces for indentation
if (defined(my $num = $args{s})) {
    $Sidef::SPACES_INCR = int($num);
}

# Interactive help
if (defined $args{H}) {
    help_interactive();
    exit 0;
}

# Interactive coding
if (defined $args{i}) {
    code_interactive();
    exit 0;
}

# Test mode
if (defined $args{t}) {
    my @argv = splice(@ARGV);

    require Encode;
    while (defined(my $script_name = shift @argv)) {

        my $script_name = Encode::decode_utf8($script_name);

        say "\n** Executing: $script_name";
        say "-" x 80;

        @Sidef::NAMESPACES = ();
        %Sidef::INCLUDED   = ();

        my $code   = read_script($script_name);
        my $parser = new_parser(name => $script_name);
        my $struct = eval { parse_code($parser, $code) };

        my $slept = 0;
        if ($@) {
            warn "[ERROR] Can't parse the script `$script_name`: $@";
            sleep 2;
            $slept = 1;
        }
        else {
            local $Sidef::PARSER = $parser;

            local $SIG{INT} = sub {
                die "Stopped by user...";
            };

            execute_struct($struct, 1);
        }

        if (not($slept) and $@) {
            warn "[ERROR] Error encountered on script `$script_name': $@";
            sleep(2) if @argv;
        }
    }
}

# Default
else {
    my $script_name = '-';

    $args{E} = $args{e} if exists($args{e});

    my $code = exists($args{E})
      ? do {
        defined($args{E}) || die "No code specified for -E.\n";
        $script_name = '-E';
        require Encode;
        Encode::decode_utf8($args{E});
      }
      : defined($ARGV[0]) && (-t STDIN or -f $ARGV[0]) ? do {
        $script_name = shift @ARGV;
        read_script($script_name);
      }
      : (-t STDIN) ? do { code_interactive(); exit }
      :              do { local $/;           <STDIN> };

    $code // exit 2;

    # Parse the code
    my $parser = new_parser(name => $script_name);
    my $struct = parse_code($parser, $code);

    # Dump the data structure
    if (defined $args{D}) {
        dump_structure($struct);
    }

    # Deparse code
    elsif (defined($args{r}) or defined($args{R})) {
        my $deparsed = deparse_structure($struct, $args{R});

        if (defined($args{R}) and lc($args{R}) eq 'perl') {

            my $header =
                "\nuse lib ("
              . join(', ', map { qq{"\Q$_\E"} } @INC)
              . ");\n\n"
              . "use Sidef;\n\n"
              . "binmode(STDIN, ':utf8');\n"
              . "binmode(STDOUT, ':utf8');\n"
              . "binmode(STDERR, ':utf8') if \$^P == 0;\n";

            $deparsed = $header . $deparsed;
        }

        output($deparsed);
    }

    # Compile the struct to a Perl program
    elsif (defined $args{c}) {
        compile_to_perl(code => deparse_structure($struct, 'Perl'), type => NATIVE);
    }

    # Check the syntax
    elsif (defined $args{C}) {
        say "$script_name syntax OK";
    }

    # Execute the struct
    else {
        local $Sidef::PARSER = $parser;
        execute_struct($struct);
    }
}

#
## Subroutines
#

sub read_script {
    my ($script_name) = @_;
    open my $fh, '<:utf8', $script_name
      or die qq{Can't open sidef script "$script_name": $!\n};
    local $/;
    <$fh>;
}

sub new_parser {
    my (%opt) = @_;
    Sidef::Parser->new(
                       opt         => \%args,
                       file_name   => $opt{name},
                       script_name => $opt{name},
                      );
}

sub optimize_struct {
    my ($struct) = @_;

    my $optimizer  = Sidef::Optimizer->new;
    my %opt_struct = $optimizer->optimize($struct);

    return \%opt_struct;
}

sub parse_code {
    my ($parser, $code) = @_;

    my $struct = $parser->parse_script(code => \$code);

    # Check for optimization
    if (defined($args{O})) {

        # Optimize the AST
        if ($args{O} >= 1) {
            $struct = optimize_struct($struct);
        }

        # Deparse the AST into code, then parse the code again.
        if ($args{O} >= 2) {
            my $deparser = Sidef::Deparse::Sidef->new(namespaces => [@Sidef::NAMESPACES]);
            my $code = $deparser->deparse($struct);

            local %Sidef::INCLUDED;
            local @Sidef::NAMESPACES;

            $struct = Sidef::Parser->new(
                                         opt         => \%args,
                                         file_name   => $parser->{file_name},
                                         script_name => $parser->{script_name},
                                        )->parse_script(code => \$code);

            $struct = optimize_struct($struct);
        }
    }

    $struct;
}

sub execute_struct {
    my ($struct, $return) = @_;
    state $count = 0;

    my $environment_name = 'Sidef::Runtime' . CORE::abs(++$count);
    my $deparser = Sidef::Deparse::Perl->new(
                                             opt              => \%args,
                                             namespaces       => [@Sidef::NAMESPACES],
                                             environment_name => $environment_name,
                                            );
    local $Sidef::DEPARSER = $deparser;
    my $code = "package $environment_name {" . $deparser->deparse($struct) . "}";
    $return ? eval($code) : do { eval($code); $@ && die $@; exit };
}

sub output_usage {
#<<<
    my %switches = (
                    '-i'         => 'interactive mode',
                    '-c'         => 'compile the code as a stand-alone Perl program',
                    '-C'         => 'check syntax only',
                    '-D'         => 'dump the syntax tree of a program',
                    '-o file'    => 'file where to dump the output',
                    '-O level'   => ['perform code optimizations before execution',
                                     'valid levels: [0], 1, 2'],
                    '-P int'     => 'set the precision of floating-point numbers (default: 32)',
                    '-M mode'    => ['set the rounding mode of floating-point numbers',
                                     'valid modes: [near], zero, inf, +inf, -inf'],
                    '-k'         => 'keep track of potential unsafe parser interpretations',
                    '-E program' => 'one line of program',
                    '-H'         => 'interactive help',
                    '-s int'     => 'the number of spaces used in code indentation',
                    '-v'         => 'print version number and exit',
                    '-t'         => 'treat all command-line arguments as scripts',
                    '-r'         => 'parse and deparse a Sidef program',
                    '-R lang'    => ['parse and deparse a Sidef program into a given language',
                                     'valid values: sidef, perl'],
                    '-w'         => 'enable warnings with stack backtrace',
                    '-W'         => 'make warnings fatal (with stack backtrace)',
    );
#>>>
    require File::Basename;
    my $basename = File::Basename::basename($0);

    print <<"USAGE";

Usage: $basename [switches] [--] [programfile] [arguments]

USAGE

    require List::Util;
    my $max_width = List::Util::max(map { length } keys %switches);
    $max_width += 4;

    foreach my $key (sort { lc($a) cmp lc($b) or lc($b) cmp lc($a) or $b cmp $a } keys %switches) {
        if (ref $switches{$key} eq 'ARRAY') {
            printf "  %-${max_width}s%s\n", $key, $switches{$key}[0];
            foreach my $i (1 .. $#{$switches{$key}}) {
                printf "  %-${max_width}s%s\n", '', $switches{$key}[$i];
            }
        }
        else {
            printf "  %-${max_width}s%s\n", $key, $switches{$key};
        }
    }

    print <<"END";

Run '$basename -H' for interactive help.

END
}

sub output_version {
    print "$name $version\n";
}

sub help_interactive {

    require File::Basename;
    require File::Spec;

    require Encode;
    require Term::ReadLine;
    my $term = Term::ReadLine->new("$name $version -- help interactive mode");

    print <<"HELP";
Welcome to $name $version!  This is the interactive help utility.

Enter the name of any object, keyword, or topic to get help on writing
$name programs and using $name modules.  To quit this help utility, just
type "quit".

HELP

    {
        my $line = Encode::decode_utf8(
            $term->readline('help> ')
              // do { print "\n"; return }
        );

        if ($line eq 'quit' or $line eq 'q') {
            return;
        }

        my $parser = new_parser(name => '-H');
        $parser->{interactive} = 1;

        my $struct = eval { parse_code($parser, $line) };

        if ($@) {
            warn $@;
            redo;
        }

        my @refs = (
            map { ref($_) } do {
                local $Sidef::PARSER = $parser;
                execute_struct($struct, 1);
              }
        );

        foreach my $ref (@refs) {
            $ref eq '' && do { warn "Not an object!\n"; next };
            my $name = $ref =~ s{::}{/}gr;
            my $file = $INC{$name . '.pm'};
            my $pod;
            foreach my $dir (@INC) {
                if (-e (my $f = File::Spec->catfile($dir, $name . '.pod'))) {
                    $pod = $f;
                    last;
                }
            }
            system 'perldoc', defined($pod) ? $pod : $ref;
        }

        redo;
    }
}

sub code_interactive {
    require Encode;
    require Term::ReadLine;

    my $term = Term::ReadLine->new("$name $version -- interactive mode");

    my $parser = new_parser(name => '-i');
    $parser->{interactive} = 1;

    print qq{$name $version on $^O\n};
    print qq{Type "help", "copyright" or "license" for more information.\n};

    my $valid_lines = '';

  MAINLOOP: {
        my $line = '';

        {
            $line .= Encode::decode_utf8($term->readline($line eq '' ? '>> ' : '   ') // return);

            if ($line eq 'help') {
                help_interactive();
                redo MAINLOOP;
            }
            elsif ($line =~ /^#\h*load\h+(.+)/) {
                @Sidef::NAMESPACES = ();
                %Sidef::INCLUDED   = ();
                my $file = unpack('A*', $1);
                open my $fh, '<:utf8', $file or do {
                    warn "Can't open file <<$file>> for read: $!\n";
                    redo MAINLOOP;
                };
                $line = do { local $/; <$fh> };
                close $fh;
            }
            elsif ($line =~ /^#\h*save\h+(.+)/) {
                my $file = unpack('A*', $1);
                open my $fh, '>:utf8', $file or do {
                    warn "Can't open file <<$file>> for write: $!\n";
                    redo MAINLOOP;
                };
                print $fh $valid_lines;
                close $fh;
                say "** Updated file <<$file>> successfully!";
            }
            elsif ($line =~ /\h\z/) {
                $line .= "\n";
                redo;
            }
            elsif ($line eq 'copyright') {
                print <<'EOT';
Copyright © 2013-2016 Daniel Șuteu, Ioana Fălcușan
All Rights Reserved.
EOT
                redo MAINLOOP;
            }
            elsif ($line eq 'license') {
                print <<'EOT';

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.

EOT
                redo MAINLOOP;
            }
        }

        # Remove 'var' declarations (if any)
        if (not defined($args{r}) and not defined($args{R})) {
            $line =~ s/^\h*var\b\h*//;
        }

        my $struct = eval { parse_code($parser, $line) };

        if ($@) {

            # Valid keywords for 'exit'
            if ($line eq 'q' or $line eq 'exit' or $line eq 'quit') {
                return;
            }

            # Otherwise a syntax-error
            warn $@;
            redo;
        }
        else {
            $valid_lines .= "$line\n";    # store valid lines
        }

        if (defined($args{r}) or defined($args{R})) {
            output(deparse_structure($struct, $args{R}));
        }
        else {
            local $Sidef::Types::Number::Number::PREC = 4 * $args{P} if exists($args{P});
            my $result = do {
                local $Sidef::PARSER = $parser;
                execute_struct($struct, 1);
            };
            print $@ if $@;
            use overload;
            say "=> ",
              (
                  ref($result)
                ? overload::StrVal($result)
                      ? "$result"
                      : eval { $result->can('dump') } ? $result->dump
                    : $result
                : defined($result) ? $result
                :                    'nil'
              );
        }
        redo;
    }
}

sub _get_namespaces {
    @Sidef::NAMESPACES
      ? ('push(@Sidef::NAMESPACES, ' . join(', ', map { qq{"\Q$_\E"} } @Sidef::NAMESPACES) . ");\n")
      : '';
}

sub _get_loaded_modules {
    my @modules;
    foreach my $key (sort { length($a) <=> length($b) || $a cmp $b } keys %INC) {
        if ($key =~ /^(Sidef\b.*)\.pm\z/) {
            push @modules, $1 =~ s{/}{::}gr;
        }
    }
    return @modules;
}

sub deparse_structure {
    my ($struct, $arg) = @_;

    my $lang   = $arg // 'Sidef';
    my $module = "Sidef::Deparse::\u\L$lang";
    my $pm     = ($module =~ s{::}{/}gr . '.pm');

    require $pm;
    my $deparser = $module->new(namespaces => [@Sidef::NAMESPACES], opt => \%args);
    my $code = $deparser->deparse($struct);

    return $code;
}

sub output {
    my ($content) = @_;

    my $out_fh = \*STDOUT;

    if (defined $args{o}) {
        open $out_fh, '>:utf8', $args{o}
          or die "Can't open file '$args{o}' for write: $!\n";
    }
    print {$out_fh} $content;

    return $out_fh;
}

sub dump_structure {
    my ($struct) = @_;

    eval { require Data::Dump };

    if ($@) {
        die qq{** "Data::Dump" is not installed!\n};
    }
    else {
        my $out_fh = output('');

        my $requirify = sub {
            join('', map { "require '" . (s{::}{/}gr) . ".pm';\n" } @_);
        };

        print {$out_fh} _get_namespaces();
        print {$out_fh} $requirify->(_get_loaded_modules());
        print {$out_fh} Data::Dump::pp($struct) . "\n";
    }
}

sub compile_to_perl {
    my (%opt) = @_;

    require File::Basename;
    my $path = File::Spec->catdir(File::Basename::dirname($INC{'Sidef.pm'}), 'Sidef');

    my $package_content = <<"HEAD";
#!$^X

eval 'exec $^X  -S \$0 \${1+"\$@"}'
    if 0; # not running under some shell

use utf8;

binmode STDIN,  ":utf8";
binmode STDOUT, ":utf8";
binmode STDERR, ":utf8" if \$^P == 0;    # to work under Devel::* modules

my %REQ;
my %MODULE;
HEAD

    if ($opt{type} == NATIVE) {
        $package_content .= "BEGIN { %MODULE = (\n";
    }

    require File::Find;
    File::Find::find(
        {
         no_chdir => 1,
         wanted   => sub {
             if (/\.pm\z/ and -f) {

                 local $/;
                 open my $fh, '<:utf8', $_
                   or die "Can't open file `$_' for reading: $!";

                 my $token   = tr/A-Za-z0-9/_/cr;
                 my $content = <$fh>;

                 if ($content =~ /^package\h+([\w:]+)/) {
                     $package_content .= qq{'$1' => };
                 }
                 else {
                     die qq{ERROR: can't get the package name from file `$_`};
                 }

                 $package_content .= qq{<<'${token}',\n};
                 $package_content .= $content;
                 $package_content .= "\n$token\n";

                 close $fh;
             }
         }
        } => ($path, $INC{'Sidef.pm'})
    );

    $package_content .= <<'FOOT';
);

sub __load_sidef_module__ {
    my ($name) = @_;
    if (not exists $REQ{$name}) {
        my $module = $name =~ s{::}{/}gr . '.pm';
        if (exists $MODULE{$name} and not exists $INC{$module}) {

            # Load the Sidef used modules
            $MODULE{$name} =~ s{^\h*
                  use \h+ (?:
                      parent \s+ qw\((.*?)\)
                    | (Sidef::[\w:]+)
                  )
            }{
                  join(
                  ";\n" => map{
                    exists($REQ{$_})
                        ? ()
                        : "BEGIN{ main::__load_sidef_module__('$_') }" } split(' ', $+)
                  ) . (defined($1) ? "\nuse parent qw($+);\n" : '')
            }gxmse;

            $INC{$module} = 1;
            eval($MODULE{$name});
            die "[FATAL ERROR] Can't load `$module`: $@" if $@;
        }
        else {
            require $module;
        }
        $REQ{$name} = 1;
    }
    return 1;
}

FOOT

    my $requirify = sub {
        join('', map { "__load_sidef_module__('$_');\n" } @_);
    };

    if ($opt{type} == NATIVE) {
        $package_content .= $requirify->(_get_loaded_modules());
        $package_content .= "}\n\n";
    }

    my $out_fh = output('');
    print {$out_fh} $package_content;

    if ($opt{type} == NATIVE) {
        print {$out_fh} $opt{code};
    }
}
