Kaleidoscope/testing/bin/ktest-to-cxx

#!/usr/bin/perl

use warnings;
use strict;
use Getopt::Long;
use File::Spec;
use Data::Dumper;

my $text_filename = "";
my $cxx_filename  = "";
my $verbose;
my $cxx_output       = "";
my $depth            = 0;
my $reports_expected = 0;
my @script_lines;
my $named_switches = {};
my $inside_test    = 0;
my $stanza         = 0;
my $test_class     = 'GeneratedKTest';

GetOptions(
    "cxx=s"   => \$cxx_filename,    # string
    "ktest=s" => \$text_filename,
    "verbose" => \$verbose
  )                                 # flag
  or die("Error in command line arguments\n");

my $test;

if ( -f $text_filename ) {
    load_from_text();
}
else {
    die "Couldn't find $text_filename";
}

generate_test_file();

open( my $outfile, ">", $cxx_filename ) || die "Can't open output file $!";
print $outfile $cxx_output;
close($outfile);

exit(0);

sub load_from_text {
    my @content = ();
    open( my $text_fh, "<", $text_filename ) or die "Can't open file $!";
    my $line_num = 0;
    for my $line (<$text_fh>) {
        my ( $key, $content, $comment, $error, $type );
        $line_num++;
        chomp $line;
        my $raw_line = $line;
        $raw_line =~ s/"/''/g;

        $line =~ s/^\s+//;
        $line =~ s/\s+$//;

        if ( $line eq '' ) {
            next;
        }
        if ( $line =~ /^(.*?)\s*#\s*(.*)$/ ) {
            $line    = $1;
            $comment = $2;
        }

        if ( $line =~ /^(.*?)\s+(.*)\s*$/ ) {
            $type    = lc $1;
            $content = $2;
        }
        else {
            $type = lc $line;
        }

        my $dispatcher = {
            version => sub {
                my $version = shift;
                if ( $version != 1 ) {
                    die "This parser only supports v1";
                }
                return undef;
            },
            name => sub {
                my $name = shift;
                $name =~ s/\s(\w)/uc($1)/eg;
                return { test_name => $name };
            },
            todo => sub { my $content = shift; return { reason => $content }; },
            end_todo  => sub { return { 1 => 1 } },
            keyswitch => sub {
                my $content = shift;
                if ( $content =~ /^(.*?)\s+(\d+)\s+(\d+)$/ ) {
                    my $switch = $1;
                    my $row    = $2;
                    my $col    = $3;
                    if ( exists $named_switches->{$switch} ) {
                        die "Attempted to redefine '$switch' on line $line_num";
                    }
                    else {
                        $named_switches->{$switch} = [ $row, $col ];
                    }
                    return undef;
                }
            },
            press => sub {
                my $content = shift;
                unless ( defined $named_switches->{$content} ) {
                    die
"Attempt to press undefined switch $content on line $line_num";
                }
                return { switch => $content };
            },
            release => sub {
                my $content = shift;
                unless ( defined $named_switches->{$content} ) {
                    die
"Attempt to release undefined switch $content on line $line_num";
                }
                return { switch => $content };
            },
            expect => sub {
                my $content = shift;
                if ( $content =~ /^no keyboard-report/ ) {
                    return {
                        report_type => 'keyboard',
                        count       => 0
                    };
                }
                if ( $content =~ /^keyboard-report\s+(.*)$/ ) {
                    my $report_data = $1;
                    my @keys        = split( /,?\s+/, $report_data );
                    if ( $#keys == 0 && $keys[0] =~ /^empty$/i ) {
                        @keys = ();
                    }
                    return {
                        count       => 1,            # We expect one report here
                        report_type => 'keyboard',
                        keys        => [@keys]
                    };
                }
                if ( $content =~ /^no mouse-report/ ) {
                    return {
                        report_type => 'mouse',
                        count       => 0
                    };
                }
                if ( $content =~ /^mouse-report\s+(.*)$/ ) {
                    my $report_data = $1;
                    my @args  = split( /,?\s+/, lc $report_data );
                    my $mouse_report_data = {};
                    $mouse_report_data->{buttons} = [];
                    $mouse_report_data->{x} = "0";
                    $mouse_report_data->{y} = "0";
                    $mouse_report_data->{v} = "0";
                    $mouse_report_data->{h} = "0";
                    if ( scalar(@args) == 1 && $args[0] =~ /^empty$/i ) {
                        @args = ();
                    }
                    for my $arg (@args) {
                        if ( $arg =~ /(\w+)=([\w\d\-\+]+)/ ) {
                            my $field = $1;
                            my $value = $2;
                            if ( $field =~ /button/ ) {
                                if ( $value =~ /^l/ ) {
                                    $value = 'MouseReport::kButtonLeft';
                                }
                                elsif ( $value =~ /^r/ ) {
                                    $value = 'MouseReport::kButtonRight';
                                }
                                elsif ( $value =~ /^m/ ) {
                                    $value = 'MouseReport::kButtonMiddle';
                                }
                                elsif ( $value =~ /^n/ ) {
                                    $value = 'MouseReport::kButtonNext';
                                }
                                elsif ( $value =~ /^p/ ) {
                                    $value = 'MouseReport::kButtonPrev';
                                }
                                else {
                                    die
"Couldn't parse mouse button value from $content at line $line_num";
                                }
                                push @{ $mouse_report_data->{buttons} }, $value;
                            }
                            elsif ( $field =~ /x/ ) {
                                $mouse_report_data->{x} = $value;
                            }
                            elsif ( $field =~ /y/ ) {
                                $mouse_report_data->{y} = $value;
                            }
                            elsif ( $field =~ /v/ ) {
                                $mouse_report_data->{v} = $value;
                            }
                            elsif ( $field =~ /h/ ) {
                                $mouse_report_data->{h} = $value;
                            }
                            else {
                                die "Don't know how parse $content at line $line_num";
                            }
                        }
                        else {
                            die "Don't know how parse $content at line $line_num";
                        }
                    }
                    return {
                        count       => 1,            # We expect one report here
                        report_type => 'mouse',
                        data        => $mouse_report_data,
                    }
                }
                else {
                    die "Don't know how parse $content at line $line_num";
                }
            },
            run => sub {
                my $content = shift;
                if ( $content =~ /^(\d+)\s*(\w*?)$/ ) {
                    my $count = $1;
                    my $unit  = $2;
                    if ( $unit =~ /cycle/ ) {
                        return { cycles => $count };
                    }
                    elsif ( $unit =~ /milli|ms/ ) {
                        return { millis => $count };
                    }
                    else {
                        die
"Line $line_num: failed to parse a 'run' clause: $content";
                    }
                }
                else {
                    die
"Line $line_num: failed to parse a 'run' clause: $content";
                }

            },
            delay => sub {
                my $content = shift;
                if ( $content =~ /^(\d+)\s*(\w*?)$/ ) {
                    my $count = $1;
                    my $unit  = $2;
                    if ( $unit =~ /milli|ms/ ) {
                        return { millis => $count };
                    }
                    else {
                        die
"Line $line_num: failed to parse a 'delay' clause: $content";
                    }
                }
                else {
                    die
"Line $line_num: failed to parse a 'delay' clause: $content";
                }

            },

        };

        my $data;
        if ( $type && exists $dispatcher->{$type} ) {
            $data = $dispatcher->{$type}->($content);

            # an empty return means "don't put it in the script
            if ( !$data ) {
                next;
            }
        }

        push @content,
          {
            action   => $type,
            content  => $content,
            comment  => $comment,
            data     => $data,
            line_num => $line_num,
            raw_line => $raw_line
          };

    }

    close($text_fh);
    @script_lines = @content;
}

sub generate_test_file {

    generate_preface();
    generate_key_addrs();

    generate_script();

    generate_postscript();

    if ( $depth != 0 ) {
        die "Unbalanced indentation: Depth is $depth";
    }
}

sub generate_key_addrs {
    cxx_section('Key Addresses');
    for my $key ( keys %$named_switches ) {

        cxx(    "constexpr KeyAddr key_addr_$key {"
              . $named_switches->{$key}->[0] . ", "
              . $named_switches->{$key}->[1]
              . "};" );

    }

}

sub generate_start_new_test {
    my $name = shift;
    if ($inside_test) {
        generate_end_test();
    }
    cxx( "TEST_F($test_class, " . $stanza++ . "_$name) {" );
    $inside_test = $name;
    indent();
    cxx("ClearState(); // Clear any state from previous tests");
}

sub generate_start_todo_test_section {
    if ($inside_test) {
        outdent();
        cxx("} // TEST_F");
        cxx('');
        cxx('');
        cxx('');
    }
    cxx( "TEST_F($test_class, DISABLED_" . $stanza++ . "_$inside_test) {" );
    indent();
}

sub generate_end_todo_test_section {
    outdent();
    cxx("} // DISABLED TEST_F");
    if ($inside_test) {
        cxx('');
        cxx('');
        cxx('');
        cxx( "TEST_F($test_class, " . $stanza++ . "_$inside_test) {" );
        indent();
    }
}

sub generate_end_test {
    generate_check_expected_reports();
    outdent();
    cxx("} // TEST_F");
    cxx('');
    cxx('');
    cxx('');
    $inside_test = 0;
}

sub generate_script {
    cxx_section("Test script");

    # Super evil hack from https://stackoverflow.com/a/48924764
    # We should do this better, inside the core. But until we do
    # I'd rather stick the macro in the code generator so nobody
    # gets to use it from regular tests, boxing us in
    cxx('#define GTEST_COUT std::cout << "[ INFO     ] "');

    generate_start_new_test('KtestSourceFilename');
    cxx(
"GTEST_COUT << \"test: @{[File::Spec->rel2abs( $text_filename ) ]}\"   << std::endl;"
    );
    generate_end_test('');

    $reports_expected = 0;
    for my $entry (@script_lines) {

        #cxx("std::cerr << \"".$entry->{raw_line}."\" << std::endl;");

        if ( $entry->{comment} && ( !$entry->{action} ) ) {
            cxx_comment( $entry->{comment} );
        }
        elsif ( my $action = $entry->{action} ) {

            if ( $action eq 'name' ) {
                generate_start_new_test( $entry->{data}->{test_name} );
            }

            elsif ( $action eq 'todo' ) {
                generate_start_todo_test_section();
                cxx(
                    "GTEST_COUT << \"TODO: @{[
			$entry->{'data'}->{'reason'} || 'The author did not specify a reason' 
			]}\"   << std::endl;"
                );

                if ( $entry->{comment} ) {
                    cxx_comment( $entry->{comment} );
                }
            }
            elsif ( $action eq 'end_todo' ) {
                if ( $entry->{comment} ) {
                    cxx_comment( $entry->{comment} );
                }

                generate_end_todo_test_section();
            }

            elsif ( !$inside_test && defined $action ) {
                die
"Attempting to run an action '$action' when not inside a test section on line "
                  . $entry->{line_num} . "\n";
            }
            elsif ( $action eq 'press' )   { generate_press($entry) }
            elsif ( $action eq 'release' ) { generate_release($entry); }
            elsif ( $action eq 'run' )     { generate_run($entry) }
            elsif ( $action eq 'delay' )   { generate_delay($entry) }
            elsif ( $action eq 'expect' )  { generate_expect_report($entry); }
            else {
                die "$action unknown on line $entry->{line_num}";
            }
        }
    }

    if ($inside_test) {
        generate_end_test();
    }

}

sub generate_run {
    my $action = shift;
    if ( $action->{'comment'} ) {
        cxx_comment( $action->{'comment'} );
    }
    if ( $action->{data}->{'cycles'} ) {
        cxx( 'sim_.RunCycles(' . $action->{data}->{'cycles'} . ');' );
    }
    elsif ( $action->{data}->{'millis'} ) {
        cxx( 'sim_.RunForMillis(' . $action->{data}->{'millis'} . ');' );
    }
}

sub generate_delay {
    my $action = shift;
    if ( $action->{'comment'} ) {
        cxx_comment( $action->{'comment'} );
    }
    if ( $action->{data}->{'millis'} ) {
        cxx( 'delay(' . $action->{data}->{'millis'} . ');' );
    }
}

sub generate_press {
    my $e = shift;

    # TODO handle multuple presses
    cxx( "PressKey(key_addr_" . $e->{data}->{switch} . "); // ", $e->{comment} );
}

sub generate_release {
    my $e = shift;

    # TODO handle multiple releases
    cxx( "ReleaseKey(key_addr_" . $e->{data}->{switch} . "); // ", $e->{comment} );
}

sub generate_expect_report {
    my $report = shift;
    if ( $report->{data}->{report_type} eq 'keyboard' ) {
        generate_expect_keyboard_report($report);
    }
    elsif ( $report->{data}->{report_type} eq 'mouse' ) {
        generate_expect_mouse_report($report);
    }
    else {
        die
"Don't know how to handle expectaions of report types other than 'keyboard' and 'mouse' at line #"
          . $report->{line_num} . "\n";
    }
    $reports_expected++;
}

sub generate_expect_keyboard_report {
    my $report = shift;

    if ( $report->{data}->{count} == 0 ) {
        if ( $report->{comment} ) {
            cxx_comment( $report->{comment} );
        }
        cxx_comment(
"We don't expect any report here, and have told the tests to check that"
        );
        return;
    }

    my $codes = join(
        ", ",
        (
            ref( $report->{data}->{keys} )
            ? @{ $report->{data}->{keys} }
            : ( $report->{data}->{keys} )
        )
    );
    cxx(    "ExpectKeyboardReport(Keycodes{$codes}, \""
          . ( $report->{comment} || 'No explanatory comment specified' )
          . "\");" );
    cxx("");
}

sub generate_expect_mouse_report {
    my $report = shift;

    if ( $report->{data}->{count} == 0 ) {
        if ( $report->{comment} ) {
            cxx_comment( $report->{comment} );
        }
        cxx_comment(
"We don't expect any report here, and have told the tests to check that"
        );
        return;
    }

    my $buttons_code = "0";
    my @buttons = ( ref( $report->{data}->{data}{buttons} )
                    ? @{ $report->{data}->{data}{buttons} }
                    : ( $report->{data}->{data}{buttons} ) );
    for my $button_value (@buttons) {
        $buttons_code .= " | $button_value";
    }
    cxx("ExpectMouseReport($buttons_code, "
        . $report->{data}{data}{x} . ", "
        . $report->{data}{data}{y} . ", "
        . $report->{data}{data}{v} . ", "
        . $report->{data}{data}{h} . ", "
        . "\""
        . ( $report->{comment} || 'No explanatory comment specified' )
        . "\");" );
    cxx("");
}

sub generate_check_expected_reports {
    cxx("");
    cxx("LoadState();");
    cxx("CheckReports();");
}

sub generate_preface {

    my $preface = <<EOF;
#include "testing/setup-googletest.h"
#include "Kaleidoscope.h"

// !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
// !! WARNING! This test file was automatically generated. !!
// !! It -will- be overwritten on on subsequent test runs. !!
// !! Do not edit it. You will be sad, when you lose all   !!
// !! your changes.                                        !!
// !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

// Source file:  @{[File::Spec->rel2abs( $text_filename ) ]}

SETUP_GOOGLETEST();

namespace kaleidoscope {
namespace testing {
namespace {

class @{[$test_class]} : public VirtualDeviceTest {};
EOF

    for my $line ( split /\n/, $preface ) {
        cxx($line);
    }
}

sub generate_postscript {

    my $postscript = <<EOF;

}  // namespace
}  // namespace testing
}  // namespace kaleidoscope
EOF

    for my $line ( split /\n/, $postscript ) {
        cxx($line);
    }
}

sub indent {
    $depth += 2;
}

sub outdent {
    $depth -= 2;
    if ( $depth < 0 ) {
        die "Tried to outdent beyond 0";
    }
}

sub cxx_section {
    my $line = shift;
    cxx('');
    cxx('');
    cxx_comment($line);
    cxx_comment( "=" x length($line) );
    cxx('');
    cxx('');
}

sub cxx_comment {
    my $line = shift;
    cxx( "// " . $line );
}

sub cxx {
    my $line    = shift;
    my $comment = shift || '';
    $cxx_output .= " " x $depth;
    $cxx_output .= $line;
    $cxx_output .= $comment if ($comment);
    $cxx_output .= "\n";
    if ($verbose) {
        debug("$line");
    }
}

sub debug {
    my $msg = shift;
    print STDERR ( " " x $depth ) . $msg . "\n";
}