#!/usr/bin/perl -w
# Copyright 2014, 2015 Kevin Ryde
# This file 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, or (at your option) any
# later version.
#
# This file 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 file.  If not, see <http://www.gnu.org/licenses/>.
use strict;
use Carp 'croak';
use FindBin;
use Getopt::Long;
use List::Util 'max';
use IPC::Run;
use POSIX ();
# uncomment this to run the ### lines
# use Smart::Comments;
our $VERSION = 0;
my $action = 'run';
my $verbose = 0;
my $stdin = 0;
my $gp_f = 1;
{
  my $help = sub {
    print "gp-inline [--options] filename...\n";
    my @opts =
      (['-h, --help',    'Print this help'],
       ['-v, --version', 'Print program version'],
       ['--verbose',     'Print extra messages'],
       ['--run',         'Run the inline tests in each FILENAME'],
       ['--extract',     'Print the test code from each FILENAME'],
       ['--defines',     'Print just the definitions from each FILENAME'],
      );
    my $width = 2 + max (map { length ($_->[0]) } @opts);
    foreach (@opts) {
      printf "%-*s%s\n", $width, $_->[0], $_->[1];
    }
    print "\n";
    exit 0;
  };
  GetOptions ('help|?' => $help,
              version => sub {
                print "$FindBin::Script version $VERSION\n";
                exit 0;
              },
              run        => sub { $action = 'run' },
              defines    => sub { $action = 'defines' },
              extract    => sub { $action = 'extract' },
              f          => \$gp_f,
              stdin      => \$stdin,
              verbose    => \$verbose,
             )
    or exit 1;
  ($stdin || @ARGV) or $help->();
}
my $total_files = 0;
my $total_expressions = 0;
### $action
my $harness;
if ($action eq 'run') {
  $harness = IPC::Run::start(['gp','--quiet',
                              ($gp_f ? '-f' : ()),
                              '--default','recover=0',
                             ],
                             '<pipe', \*GP)
    or die "Cannot run gp";
  my $flags = fcntl(GP, Fcntl::F_GETFL(),0);
  $flags &= ~ POSIX::O_NONBLOCK();
  fcntl(GP, Fcntl::F_SETFL(), $flags)
    or die "fcntl: $!";
  # printf "%b\n", $flags;
  # printf "%b\n", $flags;
  # printf "%b\n", ~ POSIX::O_NONBLOCK();
  # printf "%b\n", fcntl(GP, Fcntl::F_GETFL(),0);
}
sub output {
  if ($harness) {
    print GP @_
      or die "Error writing to gp sub-process: $!";
  } else {
    print @_;
  }
}
sub output_test {
  if ($action ne 'defines') {
    output(@_);
  }
}
output_test(<<'HERE');
check_location = "";
check_count = 0; check_good = 0; check_bad = 0;
check(x) =
{
  check_count++;
  if(x, check_good++,
        check_bad++;
        print(check_location"check fail"));
  print1();
}
check_equal(got,want) =
{
  check_count++;
  if(x==y,check_good++,
          check_bad++;
          print(check_location"check fail got "got" want "want));
  print1();
}
HERE
if ($verbose) {
  output("\\e 1\n");
}
# } elsif ($arg eq '-dist') {
#   $exit = 1;
#   require ExtUtils::Manifest;
#   my $href = ExtUtils::Manifest::maniread();
#   my @filenames = grep m{^lib/.*\.pm$|^[^/]\.pm$}, keys %$href;
#   $good &= $class->test_files(@filenames);
if ($stdin) {
  test_fh(\*STDIN, '(stdin)');
}
test_files(@ARGV);
# if ($exit) {
#   $class->diag ("gp-inline total $total_expressions checks in $total_files files");
#   exit($good ? 0 : 1);
# }
sub test_files {
  # ($filename, ...)
  foreach my $filename (@_) {
     test_file($filename);
  }
}
sub test_file {
  my ($filename) = @_;
  ### test_file(): $filename
  $total_files++;
  open my $fh, '<', $filename
    or die "Cannot open $filename: $!";
  test_fh($fh, $filename);
  close $fh
    or die "Error closing $filename: $!";
}
sub test_fh {
  my ($fh, $filename) = @_;
  my $end = '';
  my $within = '';
  my $within_linenum;
  my $join = '';
  my $linenum = 1;
  while (defined (my $line = readline $fh)) {
    $linenum = $.;
    ### $line
    ### $within
    # leave $line as remainder after Test-Pari-XXX
    #               12           3                 4                    5 6
    if ($line =~ s{^(([\#%]+|//+|(/\*))\s*|=for\s+)(Test-Pari|TEST-PARI)(-([A-Za-z]+))?:?\s*}{}) {
      my $c_comment = $3;
      my $type = ($6 || '');
      if ($c_comment) {
        $line =~ s{\*/\s*$}{};  # strip C comment close */
      }
      $line =~ s/\n$//;
      $type = uc($type);
      ### $type
      if ($type eq '') {
        # extra "" quotes here in the gp output to disguise the expressions
        # from Emacs compilation-mode
        output_test("check_location=",gp_quote($filename),"\":\"",
                    gp_quote($linenum),"\": \"",
                    "; check((()->  $line  )())\n");
      } elsif ($type eq 'DEFINE') {
        output($line,"\n");
      } elsif ($type eq 'CONSTANT') {
        output("$line = {");
        $join = "\n";
        $end = "};\n";
        $within = 'Constant';
        $within_linenum = $linenum;
      } elsif ($type eq 'VECTOR') {
        output("$line = {[");
        $join = "\n";
        $end = "]};\n";
        $within = 'Vector';
        $within_linenum = $linenum;
      } elsif ($type eq 'MATRIX') {
        output("$line = {[");
        $join = "\n";
        $end = "]};\n";
        $within = 'Matrix';
        $within_linenum = $linenum;
      } elsif ($type eq 'END') {
        if (defined $end) {
          output($end);
          undef $end;
        } else {
          print STDERR "$filename:$linenum: End without Begin\n";
          exit 1;
        }
        $within = '';
      } else {
        print STDERR "$filename:$linenum: ignoring unrecognised \"$type\"\n";
      }
    } elsif ($within eq 'Constant'
             || $within eq 'Vector'
             || $within eq 'Matrix') {
      $line =~ s/(^|[^\\])(\\\\)*%.*//; # % comments
      $line =~ s/\\[,;]/ /g;            # ignore \, or \; spacing
      $line =~ s/\\(phantom|hspace){[^}]*}/ /g;  # ignore TeX \phantom{...}
      $line =~ s/\{([+-])\}/$1/g;       # {+} or {-}
      $line =~ s/&/,/g;                 # & as field separator
      $line =~ s|\\[td]?frac\{([^}]*)}\{([^}]*)}|($1)/($2)|g;  # \frac{}{}
      $line =~ s/\\(sqrt\d+)\s*(i?)/$1$2/g;    # \sqrt2 or \sqrt3 i
      $line =~ s/([0-9.)]+)[ \t]*i/$1*I/g;     # complex number 123 i
      $line =~ s/\bi[ \t]*([0-9.]+)/I*$1/g;    # complex number i 123
      $line =~ s/([+-])[ \t]*(I)\b/$1$2/g;     # complex number +- i 123
      $line =~ s/\bi\b/I/g;             # complex number i -> I
      if ($within eq 'Matrix') {
        $line =~ s/\\\\/;/g;            # row separator \\
      } else {
        $line =~ s/;/,/g;               # semi as separator
      }
      $line =~ s|[^-+*/^()0-9.I,; \t]||sg;  # strip anything else
      $line =~ s/(^|;)(\s*,)+/$1/sg;    # strip leading commas
      $line =~ s/,(\s*,)+/,/sg;         # strip duplicated commas
      $line =~ s/,[ \t]*$//;            # strip trailing commas
      # print "\\ ",$line,"\n";
      $line =~ s/[ \t]*$//;             # strip trailing whitespace
      if ($line ne '') {
        output($join,$line,"\n");
        $join = ($line =~ /;$/ ? "\n" : ",\n");
      }
      next;
    } else {
      ### non test line ...
    }
  }
  ### EOF ...
  if ($within) {
    print STDERR "$filename:$linenum: end of file within \"$within\"\n";
    exit 1;
  }
}
sub diag {
  my $self = shift;
  if (eval { Test::More->can('diag') }) {
    Test::More::diag (@_);
  } else {
    my $msg = join('', map {defined($_)?$_:'[undef]'} @_)."\n";
    # $msg =~ s/^/# /mg;
    print STDERR $msg;
  }
}
sub gp_quote {
  my ($str) = @_;
  $str =~ s/\"/\\"/g;
  return '"'.$str.'"';
}
output_test(<<'HERE');
print("Total "check_count" tests, "check_good" good, "check_bad" bad");
if(check_bad,quit(1))
HERE
if ($harness) {
  ### finish ...
  close GP;
  if (! $harness->finish) {
    my $exit = $?;
    if (POSIX::WIFEXITED($exit)) {
      exit(POSIX::WEXITSTATUS($exit));
    } else {
      die "Error finishing gp sub-process: $?";
    }
  }
}
exit 0;