#! /usr/bin/perl
use strict;
use ParseRx;
use YAML;
use Data::Dumper;
$|++;

our $mode = 'imcc_run'; # spit verbose
my $nr = $ARGV[0];

$mode = 'dump_spit_imcc_show_run_dbg' if $nr;  # spit verbose

require Rx; # mode must be set before Rx required


sub main {
  open I, 'tests';
  while(<I>) {
    my ($testnr, $rx, $s, $xpect) = m/^\s*(\d+)\s+(\S+)\s+(\S+)\s+(\S+)/;
    next unless defined $testnr;
    next if defined $nr and $testnr != $nr;
    $s = '' if $s eq '""';
    $xpect = $xpect =~ /^match/;
    one_run( $testnr, $rx, $s, $xpect);
  }
}

sub sanity {
  die "no parrot around" unless grep { -x "$_/parrot"  } map { s|^$|.|; $_ } split /:/, $ENV{PATH};
}

sub prtln { print @_, "\n" }
sub err {}

sub yylex {
    my ($parser) = @_;
    my $rx =     $parser->YYData->{DATA}{rx};

    $$rx =~ m/\G\s+/gc;
    if ( $mode =~ 'verbose' ) {
	prtln $$rx;
	prtln ' ' x pos $$rx, '^';
    }
    return ( 'LIT', $1 )  if $$rx =~ m/\G(\w)/gc;
    return ( ':=', ':=' ) if $$rx =~ m/\G:=/gc;
    return ( 'SUF', $1 )  if $$rx =~ m/\G([+*?]\??)/gc;
    return ( 'BCKSL', $1) if $$rx =~ m/\G\\([dD])/gc;
    return ( $1, $1 )     if $$rx =~ m/\G(\W)/gc;
    return ( '', undef)   if $$rx =~ m/\G$/gc;
    die "can't find token at '"  .substr( $$rx, pos $$rx, 10) . "'";
}



sub backslashed { 
   my ($char) = @_;
   return [ 'backslashed', $ParseRx::id++, $char ]; # if $char eq 'd';
#   return [ 'not', $ParseRx::id++, [ 'backslashed', $ParseRx::id++, $char ] ] if $char eq 'D';
}

sub one_run {
    my ($testnr, $rx, $s, $xpect) = @_;

    print sprintf "%03d %-50s",  $testnr, qq|m/^$rx/  "$s" |;
    $mode .= '_imcc' if $mode =~ m/run/;
    my $p = new ParseRx();
    my %data = ( testnr => $testnr, rx => \$rx, 's' => $s, xpect => $xpect );
    $p->YYData->{DATA} = \%data;

    $ParseRx::id = 0;
    my $c = $p->YYParse( yylex => \&yylex, yyerror => \&err ); #  , yydebug => 0x01 );
    $Data::Dumper::Terse=1;

    print STDERR Dumper $c      if $mode =~ 'dump';
    print STDERR spit($c), "\n" if $mode =~ 'spit';
    if ($mode =~ 'imcc') {
	my $imcc = imcc($c, $rx, $s, $xpect);
        open O, ">a.pir" or die $!;
        print O $imcc;       
        close O;
	print STDERR $imcc if $mode =~ 'show';
    }
    if ( $mode =~ 'run') {
	system("parrot a.pir");
    }
}

# returns a perl6 representation from the intermediate one
sub spit($) { 
    my ($c) = @_;
    my ($c0, $c1, $c2, $c3) = @$c;
    return $c2                           if $c0 eq 'lit';
    return '[' .  spit($c2) . ']'        if $c0 eq 'grp';
    return '(' . spit($c2) . ')'         if $c0 eq 'capt';         # TBD
    return spit($c2) . '|' . spit($c3)   if $c0 eq 'altern';
    return spit($c2) . spit($c3)         if $c0 eq 'seq';
    return spit($c3) . $c2               if $c0 eq 'suf';
    return '$' . $c2 . ':= ' . spit($c3) if $c0 eq 'scal_capt';    # TBD
    return "\\$c2"                       if $c0 eq 'backslashed';
#    return uc spit($c2)                  if $c0 eq 'not';  # simple minded
    die 'missing alternative in spit', Dump $c;
}

no strict 'refs';


# wrapper for variables declarations and  test for success and failure

sub wrap_test {
   my ($wrapid, $not, $init, $more, $s) = @_;
   my ($failure, $success) = $not ? qw( success failure ) : qw( failure success) ;
   return <<"EOF";
.include "inc.pir"

.sub _main_
   .sym string s  # string to match
   .sym int i     # current offset
   .sym int c     # current char
   .sym int l     # string length
   i = 0
   s = "$s"
   length l, s
   goto $init
rx_init_$wrapid:
   print i
   print " no match : $failure\\n"
   end
rx_more_$wrapid:
   print i
   print "    match : $success\\n"
   end
EOF
}

# imcc generation
sub imcc {
    my ($c, $rx, $s, $xpect) = @_;
    my ($op, $id, @para) = @$c;
    my $wrapid = $ParseRx::id++;
    my ($init, $more) = &{"Rx::${op}_ep"}($id, @para);
    my ($imcc)        = &{"Rx::$op"}($id, "rx_more_$wrapid", "rx_init_$wrapid", @para);
     return wrap_test( $wrapid, !$xpect, $init, $more, $s) . 
      "$imcc  end\n.end\n";
}


main();

