#! /usr/bin/perl -w

use strict;
use File::Basename;

my $black = `tput setaf 0`;
my $blue = `tput setaf 4`;
my $cyan = `tput setaf 6`;
my $green = `tput setaf 2`;
my $red = `tput setaf 1`;
my $white = `tput setaf 7`;
my $std = `tput init`;

my $FAIL = "${red}FAIL$std";
my $PASS = "${green}PASS$std";

my $fail = 0;

# The tested program.
my $prog = 'vcsn-cat';
# The current atom kind (argument for -a).
my $labels = 'letters';
# The current weightset (argument for -w).
my $ws = 'b';
# The current context.
my $ctx = 'lal_char(abcd)_b';

# Compute the name of the context.
my %ctx =
  (
   b   => "law_char(abcd)_b",
   br  => "law_char(abcd)_ratexpset<law_char(efgh)_b>",
   z   => "law_char(abcd)_z",
   zr  => "law_char(abcd)_ratexpset<law_char(efgh)_z>",
   zrr => "law_char(abcd)_ratexpset<law_char(efgh)_ratexpset<law_char(xyz)_z>>"
  );
sub context_update()
{
  die "invalid weightset abbreviation: $ws\n"
    unless exists $ctx{$ws};
  $ctx = $ctx{$ws};
  $ctx =~ s/law/lal/g
    if $labels eq 'letters';
  $ctx;
}

# Strip leading and trailing blanks, and quote for shell.
sub quote($)
{
  my ($in) = @_;
  $in =~ s/^[ \t]*//g;
  $in =~ s/[ \t]*$//g;

  $in =~ s/([\"\$\\\`])/\\$1/g;
  "\"$in\"";
}

sub rst_title($)
{
  my ($s) = @_;
  print "\n$s\n";
  $s =~ s/./-/g;
  print "$s\n";
}

=item C<pp($in)>

Parse and pretty-print.  If it fails, prepend "! " to the error
message and return it as result.  Strip the "try -h" line.

=cut
sub pp($)
{
  my ($in) = @_;
  $in = join (' ', map { quote($_) } split (' ', $in));
  my $cmd = "$prog -C '$ctx' -E -e $in";
  my $res = `$cmd 2>&1`;
  if ($?)
    {
      # Remove invitation to run -h.
      $res =~ s/\nTry .* -h' for more.*//;
      # Remove "vcsn-cat: " and its path in error message.
      $res =~ s{^(.*/)?(lt-)?$prog:\s*}{}gm;
      # Stderr is prefixed by ! in test cases.
      $res =~ s{^}{! }gm;
    }
  chomp($res);
  $res;
}

=item C<check_rat_exp($file)

Run C<$prog> on the content of C<$file>.

=cut

sub check_rat_exp($);
sub check_rat_exp($)
{
  my ($file) = @_;

  use IO::File;
  my $in = new IO::File($file)
    or die "$file: cannot open: $!\n";
  while ($_ = $in->getline())
    {
      my $line = $in->input_line_number;
      chomp;
      s/\s*#.*//;
      next
        unless $_;

      if (/%labels: (.*)/)
        {
          if ($labels ne $1)
            {
              $labels = $1;
              context_update;
              rst_title "Context: $ctx";
            }
          next;
        }

      if (/%weight: (.*)/)
        {
          if ($ws ne $1)
            {
              $ws = $1;
              context_update;
              rst_title "Context: $ctx";
            }
          next;
        }

      if (/%include: (.*)/)
        {
          my $f = dirname($file) . "/" . $1;
          check_rat_exp($f);
          next;
        }

      m/^(.*\S)\s*(=>|==|!)\s*(.*)$/
        or die "$file:$line: invalid input: \"$_\"";
      my ($l, $op, $r) = ($1, $2, $3);
      my $L = pp($l);

=item C<fail($expression, $expected, $effective)>

Register the failure of the evaluation of C<$expression>: instead of
C<$expected>, it evaluated to C<$effective>.

=cut
      local *fail = sub ($$$)
      {
        my ($expr, $expt, $eff) = @_;
        ++$fail;
        print "- $file:$line: $FAIL: $expr\n";
        print "\n";
        print "  - exp: $expt\n";
        print "  - eff: $eff\n";
        print "\n";
      };

      # == tests that boths are equivalent.
      # => check the actual result.
      # !  error, with the given error message.
      my $R =
        ($op eq '=>'   ? $r
         : $op eq '==' ? pp($r)
         : "! $r"); # $op eq '!',
      # Empty result is a sign of failure.
      if ($L ne '' && $L eq $R)
      {
        print "- $PASS: $l $op $r";
        print " (=> $L)" if $L ne $r;
        print "\n";
      }
      else
      {
        fail("$l $op $r", $R, $L);
      }
    }
}

check_rat_exp($_)
  foreach @ARGV;

exit !!$fail;


### Setup "GNU" style for perl-mode and cperl-mode.
## Local Variables:
## perl-indent-level: 2
## perl-continued-statement-offset: 2
## perl-continued-brace-offset: 0
## perl-brace-offset: 0
## perl-brace-imaginary-offset: 0
## perl-label-offset: -2
## cperl-indent-level: 2
## cperl-brace-offset: 0
## cperl-continued-brace-offset: 0
## cperl-label-offset: -2
## cperl-extra-newline-before-brace: t
## cperl-merge-trailing-else: nil
## cperl-continued-statement-offset: 2
## End:
