use 5.010000;
use Pod::Parser;
use warnings;
use strict;
use English qw( -no_match_vars );
use Fatal qw(open close);
use Text::Diff;

our $preamble   = q{};
our $in_command = 0;
our @display;
our $default_code             = q{ no_code_defined($_) };
our $current_code             = $default_code;
our $collecting_from_line_num = -1;
our $collected_display;
our $command_countdown = 0;
our $current_file      = '!!! NO CURRENT FILE !!!';
our $display_skip      = 0;

sub no_code_defined {
    my $display = shift;
    return 'No code defined to test display:';
}

sub normalize_whitespace {
    my $text = shift;
    $text =~ s/\A\s*//xms;
    $text =~ s/\s*\z//xms;
    $text =~ s/\s+/ /gxms;
    $text;
}

sub slurp {
    open( my $fh, '<', shift );
    local ($RS) = undef;
    return <$fh>;
}

sub in_file {
    my $display = shift;
    my $file    = shift;
    my $comparison = shift;
    $comparison //= "unknown file";

    $display = normalize_whitespace($display);
    $file    = normalize_whitespace($file);
    my $location = index( $file, $display );
    return $location >= 0 ? "" : "Display in $::current_file not in $comparison";
}

sub is_file {
    my $display = shift;
    my $file    = shift;
    my $comparison = shift;
    $comparison //= "unknown file";

    $display = normalize_whitespace($display);
    $file    = normalize_whitespace($file);
    return $file eq $display ? "" : "Display in $::current_file not in $comparison";
}

my $self_marpa = slurp('../bootstrap/self.marpa');

sub in_self_marpa {
    return in_file( shift, $self_marpa, 'self.marpa' );
}

my $misc_pl = slurp('misc.pl');

sub in_misc_pl {
    return in_file( shift, $misc_pl, 'misc.pl' );
}

my $MDL_displays = slurp('MDL_displays.marpa');

sub in_MDL_displays {
    return in_file( shift, $MDL_displays, 'MDL_displays.marpa' );
}

my $equation_grammar = slurp('../example/equation.marpa');

sub is_equation_grammar {
    my $display_grammar = shift;
    my $result = is_file( $display_grammar, $equation_grammar, 'equation.marpa' );
    return $result unless $result;
    return "$result\n" . diff( \$display_grammar, \$equation_grammar );
}

my $equation_show_symbols = slurp('equation_show_symbols.out');

sub is_equation_show_symbols {
    return is_file( shift, $equation_show_symbols, 'equation_show_symbols.out' );
}

my $equation_show_rules = slurp('equation_show_rules.out');

sub is_equation_show_rules {
    return is_file( shift, $equation_show_rules, 'equation_show_rules.out');
}

my $equation_show_QDFA = slurp('equation_show_QDFA.out');

sub is_equation_show_QDFA {
    return is_file( shift, $equation_show_QDFA, 'equation_show_QDFA.out');
}

sub in_equation_show_QDFA {
    return in_file( shift, $equation_show_QDFA, 'equation_show_QDFA.out');
}

my $equation_show_earley_sets = slurp('equation_show_earley_sets.out');

sub is_equation_show_earley_sets {
    return is_file( shift, $equation_show_earley_sets, 'equation_show_earley_sets.out');
}

sub in_equation_show_earley_sets {
    return in_file( shift, $equation_show_earley_sets, 'equation_show_earley_sets.out');
}

my $equation_show_bocage = slurp('equation_show_bocage.out');

sub is_equation_show_bocage {
    return is_file( shift, $equation_show_bocage, 'equation_show_bocage.out');
}

sub in_equation_show_bocage {
    return in_file( shift, $equation_show_bocage, 'equation_show_bocage.out');
}

sub remove_code_addresses {
    my $tree_display = shift;
    $tree_display =~ s/CODE [(] 0x \p{IsXDigit}+ [)]/CODE/gxms;
}
my $equation_show_tree =
    remove_code_addresses( slurp('equation_show_tree.out') );

sub is_equation_show_tree {
    return is_file( remove_code_addresses(shift), $equation_show_tree, 'equation_show_tree.out' );
}

sub in_equation_show_tree {
    return in_file( remove_code_addresses(shift), $equation_show_tree, 'equation_show_tree.out' );
}

my $equation_trace_values = slurp('equation_trace_values.out');
sub is_equation_trace_values {
    return is_file( shift, $equation_trace_values, 'equation_trace_values.out');
}
sub in_equation_trace_values {
    return in_file( shift, $equation_trace_values, 'equation_trace_values.out');
}

my $self_show_rules = slurp('self_show_rules.out');

sub in_self_show_rules {
    return in_file( shift, $self_show_rules, 'self_show_rules.out');
}

my $bin_mdl = slurp('../bin/mdl');

sub in_bin_mdl {
    return in_file( shift, $bin_mdl, 'bin/mdl' );
}

my $null_value_grammar = slurp('../example/null_value.marpa');

sub in_null_value_grammar {
    return in_file( shift, $null_value_grammar, '../example/null_value.marpa');
}

my $synopsis_pl = slurp('../example/synopsis.pl');

sub is_synopsis_pl {
    return is_file( shift, $synopsis_pl, '../example/synopsis.pl');
}

sub in_synopsis_pl {
    return in_file( shift, $synopsis_pl, '../example/synopsis.pl');
}

my $ah2_t = slurp('../t/ah2.t');

sub in_ah2_t {
    return in_file( shift, $ah2_t, '../t/ah2.t');
}

my $ah_s_t = slurp('../t/ah_s.t');

sub in_ah_s_t {
    return in_file( shift, $ah_s_t, '../t/ah_s.t');
}

my $cycle2_t = slurp('../t/cycle2.t');
sub in_cycle2_t {
    return in_file( shift, $cycle2_t, '../t/cycle2.t');
}

my $equation_s_t = slurp('../t/equation_s.t');

sub in_equation_s_t {
    return in_file( shift, $equation_s_t, '../t/equation_s.t');
}

my $equation_t = slurp('../t/equation.t');

sub in_equation_t {
    return in_file( shift, $equation_t, '../t/equation.t');
}

package MyParser;
@MyParser::ISA = qw(Pod::Parser);
use Carp;

sub queue_display {
    my $display  = shift;
    my $line_num = shift;
    push @::display,
        {
        'display' => $display,
        'code'    => $::current_code,
        'file'    => $::current_file,
        'line'    => $line_num,
        }
        if not $::display_skip;
    $::command_countdown--;
    if ( $::command_countdown <= 0 ) {
        $::current_code = $::default_code;
        $::display_skip = 0;
    }
}

sub verbatim {
    my ( $parser, $paragraph, $line_num ) = @_;

    if ( defined $::collected_display ) {
        $::collected_display .= $paragraph;
        $::collecting_from_line_num //= $line_num;
        return;
    }
    queue_display( $paragraph, $line_num );
}

sub process_instruction {
    my $instruction = shift;
    my $code        = shift;
    my $line_num    = shift;

    $instruction =~ s/\s$//;     # eliminate trailing whitespace
    $instruction =~ s/\s/ /g;    # normalize whitespace
    given ($instruction) {
        when (/^next display$/) {
            $::command_countdown = 1;
            $::current_code = join( "\n", @{$code} );
        }
        when (/^next\s+(\d+)\s+display(s)?$/) {
            $::command_countdown = $1;
            croak(
                "File: $::current_file  Line: $line_num\n",
                "  'next $::command_countdown display' has countdown less than one\n"
            ) unless $::command_countdown >= 1;
            $::current_code = join( "\n", @{$code} );
        }
        when (/^default$/) {
            $::default_code = join( "\n", @{$code} );
            $::current_code = $::default_code if $::command_countdown <= 0;
        }
        when (/^preamble$/) {
            $::preamble .= join( "\n", @{$code} );
        }
        when (/^skip display$/) {
            $::command_countdown = 1;
            $::display_skip++;
        }
        when (/^skip (\d+) display(s)?$/) {
            $::command_countdown = $1;
            croak(
                "File: $::current_file  Line: $line_num\n",
                "  'display $::command_countdown skip' has countdown less than one\n"
            ) unless $::command_countdown >= 1;
            $::display_skip++;
        }
        when (/^start\s+display$/) {
            $::collected_display = q{};

            # line num will be set when first part of display is found
        }
        when (/^end\s+display$/) {
            queue_display( $::collected_display,
                $::collecting_from_line_num );
            $::collected_display        = undef;
            $::collecting_from_line_num = -1;
        }
        default {
            croak(
                "File: $::current_file  Line: $line_num\n",
                "  unrecognized instruction: '$_'\n"
            );
        }
    }    # given
}

sub textblock {
    return unless $in_command;
    my ( $parser, $paragraph, $line_num ) = @_;

    ## Translate/Format this block of text; sample actions might be:

    my @lines = split /\n/, $paragraph;
    my $found_instruction = 0;
    LINE: while ( my $line = shift @lines ) {
        next LINE if $line =~ /^\s*$/xms;    # skip whitespace
        if ( $line =~ /^[#][#]/xms ) {
            $line =~ s/^[#][#]\s*//;
            process_instruction( $line, \@lines, $line_num );
            $found_instruction = 1;
            next LINE;
        }
        croak( "File: $::current_file  Line: $line_num\n",
            "test block doesn't begin with ## instruction\n$paragraph" )
            if not $found_instruction;
        last LINE;
    }

    return;

}

sub interior_sequence { }

sub command {

    my ( $parser, $command, $paragraph ) = @_;
    given ($command) {
        when ('begin') {
            $in_command++ if $paragraph =~ /^Parse::Marpa::test_document:\n/;
            $in_command++ if $paragraph =~ /^make:\n/;
        }
        when ('end') { $in_command = 0; }
        default {;};
    }

}

package main;

my @default_files = qw(
    ../lib/Parse/Marpa/Doc/Algorithm.pod
    ../lib/Parse/Marpa/Doc/Bibliography.pod
    ../lib/Parse/Marpa/Doc/Diagnostics.pod
    ../lib/Parse/Marpa/Doc/Internals.pod
    ../lib/Parse/Marpa/Doc/MDL.pod
    ../lib/Parse/Marpa/Doc/Parse_Terms.pod
    ../lib/Parse/Marpa/Doc/Plumbing.pod
    ../lib/Parse/Marpa/Doc/To_Do.pod
    ../lib/Parse/Marpa/Evaluator.pm
    ../lib/Parse/Marpa/Grammar.pm
    ../lib/Parse/Marpa/Lex.pm
    ../lib/Parse/Marpa/MDL.pm
    ../lib/Parse/Marpa/Recognizer.pm
    ../lib/Parse/Marpa.pm
);

my $parser = new MyParser();

my @files = @ARGV ? @ARGV : @default_files;

for my $file (@files) {

    $::current_file      = $file;
    @::display           = ();
    $::default_code      = q{ no_code_defined($_) };
    $::current_code      = $default_code;
    $::command_countdown = 0;
    $::display_skip      = 0;
    my $problems = 0;

    $parser->parse_from_file($file);
    eval $preamble;
    croak($EVAL_ERROR) if $EVAL_ERROR;

    # say scalar @::display, " display blocks to test in $file";
    for my $display_test (@::display) {
        my ( $display, $code, $file, $line ) =
            @{$display_test}{qw(display code file line)};
        local $_ = $display;
        my $message = eval $code;
        croak($EVAL_ERROR) if $EVAL_ERROR;
        if ($message) {
            print "=== $message\n$display";
            $problems++;
        }
    }    # $display_test
    say $problems, " display blocks with problems in $file"
        if $problems > 0;
}
