File Coverage

blib/lib/MarpaX/Hoonlint/yahc.pm

Criterion	Covered	Total	%
statement	45	300	15.0
branch	1	92	1.0
condition	2	12	16.6
subroutine	9	22	40.9
pod			n/a
total	57	426	13.3

use 5.010;
use strict;
use warnings;
use English qw( -no_match_vars );
use Data::Dumper;

use Marpa::R2 6.000;

# This code uses as its grammar reference the code in
# the arvo repo: https://github.com/urbit/arvo
# File sys/hoon.hoon: https://github.com/urbit/arvo/blob/master/sys/hoon.hoon
# as of commit 7dc3eb1cfacaaafd917697a544bdcf7f22e09eeb

package MarpaX::Hoonlint::YAHC;

use English qw( -no_match_vars );

sub deprecated {
    my $slg      = $Marpa::R2::Context::slg;
    my $rule_id  = $Marpa::R2::Context::rule;
    my ($lhs_id) = $slg->rule_expand($rule_id);
    return [ 'deprecated', $slg->symbol_display_form($lhs_id) ];
}


# === Automatically generated Marpa rules ===

# Here is meta-programming to write piece 2

# ace and gap are not really char names,
# and are omitted
my %glyphs = (
    bar => '|',
    bas => '\x5c', # '\'
    buc => '$',
    cab => '_',
    cen => '%',
    col => ':',
    com => ',',
    doq => '"',
    dot => '.',
    fas => '/',
    gal => '<',
    gar => '>',
    hax => '#',
    hep => '-',
    kel => '{',
    ker => '}',
    ket => '\\^',
    lus => '+',
    pal => '(',
    pam => '&',
    par => ')',
    pat => '@',
    pel => '(',
    per => ')',
    sel => '\x5b', # '['
    sem => ';',
    ser => '\x5d', # ']'
    sig => '~',
    soq => '\'',
    tar => '*',
    tec => '`',
    tis => '=',
    wut => '?',
    zap => '!',
);

my @glyphRules = ();
for my $glyphName (sort keys %glyphs) {
    my $glyph = $glyphs{$glyphName};
    my $ucGlyphName = uc $glyphName;
    my $uc4hGlyphName = $ucGlyphName . '4H';
    my $lcGlyphName = $glyphName . '4h';
    push @glyphRules, "$ucGlyphName ~ $lcGlyphName";
    push @glyphRules, "$uc4hGlyphName ~ $lcGlyphName";
    push @glyphRules, "$lcGlyphName ~ [" . $glyph . q{]};
    push @glyphRules, "inaccessible_ok ::= $ucGlyphName";
    push @glyphRules, "inaccessible_ok ::= $uc4hGlyphName";
}
my $glyphAutoRules = join "\n", @glyphRules;

my $mainDSL = do { $RS = undef;  };

my @dslAutoRules = ();
DESC: for my $desc (split "\n", $mainDSL) {
    my $originalDesc = $desc;
    chomp $desc; # remove newline
    next DESC if not $desc =~ s/^[#] FIXED: //;
    $desc =~ s/^\s+//; # eliminate leading spaces
    $desc =~ s/\s+$//; # eliminate trailing spaces
    my ($rune, @samples) = split /\s+/, $desc;
    die $originalDesc if not $rune;
    push @dslAutoRules, doFixedRune( $rune, @samples );
}
my $dslAutoRules = join "\n", @dslAutoRules;

# Assemble the base BSL
my $baseDSL = join "\n", $mainDSL, $glyphAutoRules, $dslAutoRules;

my $defaultSemantics = <<'EOS';
# start and length will be needed for production
# :default ::= action => [name,start,length,values]
:default ::= action => [name,values]
lexeme default = latm => 1
EOS

sub divergence {
    die join '', 'Unrecoverable internal error: ', @_;
}

# Given an input and an offset into that input,
# it reads a triple quote (''').  The return values
# are the parse value and a new offset in the input.
# Errors are thrown.

sub getTripleQuote {
    my ( $input, $offset ) = @_;
    my $input_length = length ${$input};
    my $resume_pos;
    my $this_pos;

    my $nextNL = index ${$input}, "\n", $offset;
    if ($nextNL < 0) {
      die join '', 'Newline missing after triple quotes: "', ${$input}, '"'
    }
    my $initiator = substr ${$input}, $offset, $nextNL-$offset;
    if ($initiator ne "'''" and $initiator !~ m/^''' *::/) {
      die join '', 'Disallowed characters after initial triple quotes: "', $initiator, '"'
    }

    pos ${$input} = $offset;
    my ($indent) = ${$input} =~ /\G( *)[^ ]/g;
    my $terminator = $indent . "'''";

    my $terminatorPos = index ${$input}, $terminator, $nextNL;
    my $value = substr ${$input}, $nextNL+1, ($terminatorPos - $nextNL);

    say STDERR "Left main READ loop" if $MarpaX::Hoonlint::YAHC::DEBUG;

    # Return ref to value and new offset
    return \$value, $terminatorPos + length $terminator;
}

# Given an input and an offset into that input,
# it reads a triple double quote (""").  The return values
# are the parse value and a new offset in the input.
# Errors are thrown.

# TODO: Needs to implement reading of sump(5d)

sub getTripleDoubleQuote {
    my ( $input, $offset ) = @_;
    my $input_length = length ${$input};
    my $resume_pos;
    my $this_pos;

    my $nextNL = index ${$input}, "\n", $offset;
    if ($nextNL < 0) {
      die join '', 'Newline missing after triple double quotes: "',
	${$input}, '"'
    }
    my $initiator = substr ${$input}, $offset, $nextNL-$offset;
    if ($initiator ne q{"""}) {
      die join '',
	'Disallowed characters after initial triple double quotes: "', $initiator, '"'
    }

    pos ${$input} = $offset;
    my ($indent) = ${$input} =~ /\G( *)[^ ]/g;
    my $terminator = $indent . q{"""};

    my $terminatorPos = index ${$input}, $terminator, $nextNL;
    my $value = substr ${$input}, $nextNL+1, ($terminatorPos - $nextNL);

    say STDERR "Left main READ loop" if $MarpaX::Hoonlint::YAHC::DEBUG;

    # Return ref to value and new offset
    return \$value, $terminatorPos + length $terminator;
}

# Given an input and an offset into that input,
# it reads unmarkdown.  The return values
# are the parse value and a new offset in the input.
# Reading is not intelligent -- it finds a terminator, and
# treats the unmarkdown as a string.
# Errors are thrown.

sub getCram {
    # $DB::single = 1;

    my ( $input, $origOffset ) = @_;
    my $input_length = length ${$input};
    my $resume_pos;
    my $this_pos;

    my $semiPos = rindex ${$input}, ';', $origOffset;
    my $previousNlPos = rindex ${$input}, "\n", $semiPos;
    my $indent = $semiPos - ($previousNlPos + 1);
    my $firstNlPos = index ${$input}, "\n", $semiPos;
    my $valueStartPos      = $semiPos + 2;
    my $nextNlPos = $firstNlPos;
    # say STDERR qq{origOffset: }, substr(${$input}, $origOffset, 20);
    # say STDERR qq{First NL pos: }, substr(${$input}, $firstNlPos, 20);

    if ($indent <= 0) {
	# say STDERR "indent=$indent; nextNlPos=$nextNlPos";
        LINE: while ($nextNlPos >= 0) {
            pos ${$input} = $nextNlPos + 1;
            if ( ${$input} =~ m/\G [ ]* == [\n]/xms ) {
                my $terminatorStartPos = $LAST_MATCH_START[0];
                my $terminatorEndPos   = $LAST_MATCH_END[0];
                my $value              = substr( ${$input}, $valueStartPos,
                    $terminatorStartPos - $valueStartPos );
                return \$value, $nextNlPos;
            }
	    $nextNlPos = index ${$input}, "\n", $nextNlPos+1;
        }
	# If here, end of string is EOF
	my $inputLength = length ${$input};
	my $value = substr ${$input}, $valueStartPos, $inputLength - $valueStartPos;
	return \$value, $inputLength;
    }

    # If here, indent > 0
    my $indentString = (' ' x $indent);

    LINE: while ($nextNlPos >= 0) {
	# say STDERR "LINE: indent=$indent; nextNlPos=$nextNlPos";
	pos ${$input} = $nextNlPos + 1;
	# say STDERR qq{Pos set to: }, substr(${$input}, $nextNlPos+1, 20);
	if ( ${$input} =~ m/\G $indentString [ ]* == [\n]/xms ) {
	    my $terminatorStartPos = $LAST_MATCH_START[0];
	    # say STDERR qq{TISTIS found: }, substr(${$input}, $terminatorStartPos, 20);
	    my $value              = substr( ${$input}, $valueStartPos,
		$terminatorStartPos - $valueStartPos );
	    # Continue parsing after TISTIS?  Or before?
	    return \$value, $nextNlPos;
	}

	if ( (substr ${$input}, $nextNlPos+1, $indent) eq $indentString ) {
	    $nextNlPos = index ${$input}, "\n", $nextNlPos+1;
	    # say STDERR qq{Continuing cram, nextNlPos=$nextNlPos};
	    # say STDERR qq{Continuing cram: }, substr(${$input}, $nextNlPos, 20);
	    next LINE;
	}
	# If here, outdent
	# say STDERR qq{Outdent, returning at: }, substr(${$input}, $nextNlPos+1, 20);
	my $value              = substr ${$input}, $valueStartPos,
	  ($nextNlPos + 1) - $valueStartPos;
	return \$value, $nextNlPos+1;
    }

    # Premature EOF if here
    return;
}

# The 'semantics' named argument must be considered "internal"
# for now -- any change in the grammar could break any or all of
# apps.  When the grammar can be frozen, the 'semantics' argument
# can become a "documented" feature.
#
# In the meantime, applications which want stability can simply
# copy in this file lexically, losing the advantage of updates,
# but guaranteeing stability.
sub new {
    my ($class, @argHashes) = @_;
    my $self      = {};
    for my $argHash (@argHashes) {
      ARG_NAME: for my $argName ( keys %{$argHash} ) {
            if ( $argName eq 'all_symbols' ) {
                $self->{all_symbols} = $argHash->{all_symbols};
                next ARG_NAME;
            }
            if ( $argName eq 'semantics' ) {
                $self->{semantics} = $argHash->{semantics};
                next ARG_NAME;
            }
            die "MarpaX::Hoonlint::YAHC::new() called with unknown arg name: $argName";
        }
    }
    my $semantics = $self->{semantics} // $defaultSemantics;
    if ( $self->{all_symbols} ) {
        ## show all symbols
        $baseDSL =~ s/[(][-] //g;
        $baseDSL =~ s/ [-][)]//g;
    }
    else {
        ## hide selected symbols
        $baseDSL =~ s/[(][-] /(/g;
        $baseDSL =~ s/ [-][)]/)/g;
    }
    my $dsl = $semantics . $baseDSL;

    my $grammar = Marpa::R2::Scanless::G->new( { source => \$dsl } );
    $self->{dsl} = $dsl;
    $self->{grammar} = $grammar;
    return bless $self, $class;
}

sub recceStart {
    my ($self) = @_;
    my $debug = $MarpaX::Hoonlint::YAHC::DEBUG;
    my $recce = Marpa::R2::Scanless::R->new(
        {
            grammar         => $self->{grammar},
            ranking_method  => 'high_rule_only',
            trace_lexers    => ( $debug ? 1 : 0 ),
            trace_terminals => ( $debug ? 1 : 0 ),
        }
    );
    $self->{recce} = $recce;
    return $self;
}

sub dsl {
    my ($self) = @_;
    return $self->{dsl};
}

sub rawGrammar {
    my ($self) = @_;
    return $self->{grammar};
}

sub rawRecce {
    my ($self) = @_;
    return $self->{recce};
}

sub read {
    my ($self, $input) = @_;
    $self->recceStart();
    my $recce = $self->{recce};
    my $debug = $MarpaX::Hoonlint::YAHC::DEBUG;
    my $input_length = length ${$input};
    my $this_pos;
    my $ok = eval { $this_pos = $recce->read( $input ) ; 1; };
    if (not $ok) {
       say STDERR $recce->show_progress(0, -1) if $debug;
       die $EVAL_ERROR;
    }

    # The main read loop.  Read starting at $offset.
    # If interrupted execute the handler logic,
    # and, possibly, resume.
    say STDERR "this_pos=$this_pos ; input_length=$input_length" if $debug;

  READ:
    while ( $this_pos < $input_length ) {

	my $resume_pos;

        # Only one event at a time is expected -- more
        # than one is an error.  No event means parsing
        # is exhausted.

        my $events      = $recce->events();
        my $event_count = scalar @{$events};
        if ( $event_count < 0 ) {
            last READ;
        }
        if ( $event_count != 1 ) {
            divergence("One event expected, instead got $event_count");
        }

        # Find the event name

        my $event = $events->[0];
        my $eventName  = $event->[0];

	say STDERR "$eventName event" if $MarpaX::Hoonlint::YAHC::DEBUG;

        if ( $eventName eq 'tripleQuote' ) {
            my $value_ref;
            ( $value_ref, $resume_pos ) = getTripleQuote( $input, $this_pos );
	    return if not $value_ref;
            my $result = $recce->lexeme_read(
                'TRIPLE_QUOTE_STRING',
                $this_pos,
                ( length ${$value_ref} ),
                [ ${$value_ref} ]
            );
            say STDERR "lexeme_read('TRIPLE_QUOTE_STRING',...) returned ",
              Data::Dumper::Dumper( \$result )
              if $MarpaX::Hoonlint::YAHC::DEBUG;
        }

	# TODO: tripeDoubleQuote must allow sump(5d)
        if ( $eventName eq 'tripleDoubleQuote' ) {
            my $value_ref;
            ( $value_ref, $resume_pos )
	      = getTripleDoubleQuote( $input, $this_pos );
	    return if not $value_ref;
            my $result = $recce->lexeme_read(
                'TRIPLE_DOUBLE_QUOTE_STRING',
                $this_pos,
                ( length ${$value_ref} ),
                [ ${$value_ref} ]
            );
            say STDERR "lexeme_read('TRIPLE_DOUBLE_QUOTE_STRING',...) returned ",
              Data::Dumper::Dumper( \$result )
              if $MarpaX::Hoonlint::YAHC::DEBUG;
	}

        if ( $eventName eq '^CRAM' ) {
            my $value_ref;
            ( $value_ref, $resume_pos )
	      = getCram( $input, $this_pos );
	    if (not $value_ref) {
		# TODO: After development, add "if $debug"
		say STDERR $recce->show_progress( 0, -1 );
		my $badStart = substr ${$input}, $this_pos, 50;
		die join '', 'Problem in getCram: "', $badStart, '"';
	    }
            my $result = $recce->lexeme_read(
                'CRAM',
                $this_pos,
                ( length ${$value_ref} ),
                [ ${$value_ref} ]
            );
            say STDERR "lexeme_read('CRAM',...) returned ",
              Data::Dumper::Dumper( \$result )
              if $MarpaX::Hoonlint::YAHC::DEBUG;
	}

	if (not $resume_pos) {
	  die "read() ended prematurely\n",
	    "  input length = $input_length\n",
	    "  length read = $this_pos\n",
	    qq{  the cause was an "$eventName" event};
	}

	say STDERR "this_pos=$this_pos ; input_length=$input_length" if $debug;

	# say STDERR qq{Resuming at "}, substr ${$input}, $resume_pos, 50;

        my $ok = eval { $this_pos = $recce->resume($resume_pos); 1; };
        if ( not $ok ) {
            say STDERR $recce->show_progress( 0, -1 ) if $debug;
            die $EVAL_ERROR;
        }

    }
    return;
}

sub parse {
    my ($input) = @_;
    my $debug = $MarpaX::Hoonlint::YAHC::DEBUG;
    my $self = MarpaX::Hoonlint::YAHC->new();
    $self->read($input);
    my $recce = $self->{recce};

    if ( 0 ) {
    # if ( $recce->ambiguity_metric() > 1 ) {

        # The calls in this section are experimental as of Marpa::R2 2.090
        my $asf = Marpa::R2::ASF->new( { slr => $recce } );
        say STDERR 'No ASF' if not defined $asf;
        my $ambiguities = Marpa::R2::Internal::ASF::ambiguities($asf);
        my @ambiguities = grep { defined } @{$ambiguities}[ 0 .. 1 ];
        die
          "Parse of BNF/Scanless source is ambiguous\n",
          Marpa::R2::Internal::ASF::ambiguities_show( $asf, \@ambiguities );
    } ## end if ( $recce->ambiguity_metric() > 1 )
    # }

    my $valueRef = $recce->value();
    if ( !$valueRef ) {
	say STDERR $recce->show_progress( 0, -1 ) if $debug;
        die "input read, but there was no parse";
    }

    return $valueRef;
}

# Takes one argument and returns a ref to an array of acceptable
# nodes.  The array may be empty.  All scalars are acceptable
# leaf nodes.  Acceptable interior nodes have length at least 1.
sub prune {
    no warnings 'recursion';
    my ($v) = @_;

    state $deleteIfEmpty = {
        optKets => 1,
    };

    state $nonSemantic = {
        doubleStringElements => 1,
        fordFile             => 1,
        fordHoop             => 1,
        fordHoopSeq          => 1,
        hoonExpression       => 1,
        wideLong5d           => 1,
        norm5d               => 1,
        norm5dMold           => 1,
        rope5d               => 1,
        rump5d               => 1,
        scad5d               => 1,
        scat5d               => 1,
        tall5d               => 1,
        tall5dSeq            => 1,
        teakChoice           => 1,
        till5d               => 1,
        till5dSeq            => 1,
        togaElements         => 1,
        wedeFirst            => 1,
        wide5d               => 1,
        wide5dChoices        => 1,
        wide5dJog            => 1,
        wide5dJogging        => 1,
        wide5dJogs           => 1,
        wide5dSeq            => 1,
        wideNorm5d           => 1,
        wideNorm5dMold       => 1,
        wideTeakChoice       => 1,
        wyde5d               => 1,
        wyde5dSeq            => 1,
    };

    return [] if not defined $v;
    my $reftype = ref $v;
    return [$v] if not $reftype; # An acceptable leaf node
    return prune($$v) if $reftype eq 'REF';
    divergence("Tree node has reftype $reftype") if $reftype ne 'ARRAY';
    my @source = grep { defined } @{$v};
    my $element_count = scalar @source;
    return [] if $element_count <= 0; # must have at least one element
    my $name = shift @source;
    my $nameReftype = ref $name;
    # divergence("Tree node name has reftype $nameReftype") if $nameReftype;
    if ($nameReftype) {
      my @result = ();
      ELEMENT:for my $element ($name, @source) {
	if (ref $element eq 'ARRAY') {
	  push @result, grep { defined }
		  map { @{$_}; }
		  map { prune($_); }
		  @{$element}
		;
	  next ELEMENT;
	}
	push @result, $_;
      }
      return [@result];
    }
    if (defined $deleteIfEmpty->{$name} and $element_count == 1) {
      return [];
    }
    if (defined $nonSemantic->{$name}) {
      # Not an acceptable branch node, but (hopefully)
      # its children are acceptable
      return [ grep { defined }
	      map { @{$_}; }
	      map { prune($_); }
	      @source
	    ];
    }

    # An acceptable branch node
    my @result = ($name);
    push @result, grep { defined }
	    map { @{$_}; }
	    map { prune($_); }
	    @source;
    return [\@result];
}

# takes LC alphanumeric rune name and samples
# for N-fixed rune and returns the Marpa rules
# for the tall and the 2 regular wide forms.
sub doFixedRune {
    my ($runeName, @samples) = @_;
    my @result = (join ' ', '#', (uc $runeName), @samples);
    my $glyphName1 = substr($runeName, 0, 3);
    my $glyphName2 = substr($runeName, 3, 3);
    my $glyph1 = $glyphs{$glyphName1} or die "no glyph for $glyphName1";
    my $glyph2 = $glyphs{$glyphName2};
    my $glyphLexeme1 = ($glyphName1) . '4h';
    my $glyphLexeme2 = ($glyphName2) . '4h';
    my $tallLHS = 'tall' . ucfirst $runeName;
    my $wideLHS = 'wide' . ucfirst $runeName;
    my $tallRuneLexeme = (uc $runeName) . 'GAP';
    my $wideRuneLexeme = (uc $runeName) . 'PEL';

    # norm5d ::= tallBarhep
    push @result, 'norm5d ::= ' . $tallLHS;

    # wideNorm5d ::= wideBarhep
    push @result, 'wideNorm5d ::= ' . $wideLHS;

    # tallBarhep ::= (- BAR4H HEP4H GAP -) tall5d (- GAP -) tall5d
    push @result, $tallLHS . ' ::= (- '
      . $tallRuneLexeme
      . ' -) ' . (join ' (- GAP -) ', @samples);
    state $wideEquiv = {
        bont5d => 'wideBont5d',
        bonz5d => 'wideBonz5d',
        mold   => 'wyde5d',
        tall5d => 'wide5d',
        rack5d => 'wideRack5d',
        rick5d => 'wideRick5d',
        ruck5d => 'wideRuck5d',
        teak5d => 'wideTeak5d',
    };
    my @wideSamples = map { $wideEquiv->{$_} // $_; } @samples;

    # wideBarhep ::= (- BARHEPPEL -) wide5d (- ACE -) wide5d (- PER -)
    push @result, $wideLHS . ' ::= (- '
    . $wideRuneLexeme
    . ' -) ' . (join ' (- ACE -) ', @wideSamples) . q{ (- PER -)};

    # BARHEPGAP ~ bar4h hep4h gap4k
    # BARHEPPEL ~ bar4h hep4h pel4h
    push @result, "$tallRuneLexeme ~ $glyphLexeme1 $glyphLexeme2 gap4k";
    push @result, "$wideRuneLexeme ~ $glyphLexeme1 $glyphLexeme2 pel4h";

    return join "\n", @result, '';
}

1;

# The "FIXED:" comments lines are descriptons of the fixed length runes
# (1-fixed, 2-fixed, 3-fixed and 4-fixed) for auto-generation
# of Marpa rules for the various regular formats, both
# tall and wide.
#
# The format is
#
#   rune type1 type2 ...

# Organization is by hoon.hoon (and Hoon Library) sections: 4a, 5d, etc.;
# and within that alphabetically by "face" name

__DATA__