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


line stmt bran cond sub pod time code
1 1     1   85 use 5.010;
  1         6  
2 1     1   7 use strict;
  1         3  
  1         25  
3 1     1   6 use warnings;
  1         2  
  1         38  
4 1     1   6 use English qw( -no_match_vars );
  1         2  
  1         7  
5 1     1   282 use Data::Dumper;
  1         3  
  1         53  
6              
7 1     1   552 use Marpa::R2 6.000;
  1         142422  
  1         62  
8              
9             # This code uses as its grammar reference the code in
10             # the arvo repo: https://github.com/urbit/arvo
11             # File sys/hoon.hoon: https://github.com/urbit/arvo/blob/master/sys/hoon.hoon
12             # as of commit 7dc3eb1cfacaaafd917697a544bdcf7f22e09eeb
13              
14             package MarpaX::Hoonlint::YAHC;
15              
16 1     1   11 use English qw( -no_match_vars );
  1         2  
  1         9  
17              
18             sub deprecated {
19 0     0   0 my $slg = $Marpa::R2::Context::slg;
20 0         0 my $rule_id = $Marpa::R2::Context::rule;
21 0         0 my ($lhs_id) = $slg->rule_expand($rule_id);
22 0         0 return [ 'deprecated', $slg->symbol_display_form($lhs_id) ];
23             }
24              
25              
26             # === Automatically generated Marpa rules ===
27              
28             # Here is meta-programming to write piece 2
29              
30             # ace and gap are not really char names,
31             # and are omitted
32             my %glyphs = (
33             bar => '|',
34             bas => '\x5c', # '\'
35             buc => '$',
36             cab => '_',
37             cen => '%',
38             col => ':',
39             com => ',',
40             doq => '"',
41             dot => '.',
42             fas => '/',
43             gal => '<',
44             gar => '>',
45             hax => '#',
46             hep => '-',
47             kel => '{',
48             ker => '}',
49             ket => '\\^',
50             lus => '+',
51             pal => '(',
52             pam => '&',
53             par => ')',
54             pat => '@',
55             pel => '(',
56             per => ')',
57             sel => '\x5b', # '['
58             sem => ';',
59             ser => '\x5d', # ']'
60             sig => '~',
61             soq => '\'',
62             tar => '*',
63             tec => '`',
64             tis => '=',
65             wut => '?',
66             zap => '!',
67             );
68              
69             my @glyphRules = ();
70             for my $glyphName (sort keys %glyphs) {
71             my $glyph = $glyphs{$glyphName};
72             my $ucGlyphName = uc $glyphName;
73             my $uc4hGlyphName = $ucGlyphName . '4H';
74             my $lcGlyphName = $glyphName . '4h';
75             push @glyphRules, "$ucGlyphName ~ $lcGlyphName";
76             push @glyphRules, "$uc4hGlyphName ~ $lcGlyphName";
77             push @glyphRules, "$lcGlyphName ~ [" . $glyph . q{]};
78             push @glyphRules, "inaccessible_ok ::= $ucGlyphName";
79             push @glyphRules, "inaccessible_ok ::= $uc4hGlyphName";
80             }
81             my $glyphAutoRules = join "\n", @glyphRules;
82              
83             my $mainDSL = do { $RS = undef; };
84              
85             my @dslAutoRules = ();
86             DESC: for my $desc (split "\n", $mainDSL) {
87             my $originalDesc = $desc;
88             chomp $desc; # remove newline
89             next DESC if not $desc =~ s/^[#] FIXED: //;
90             $desc =~ s/^\s+//; # eliminate leading spaces
91             $desc =~ s/\s+$//; # eliminate trailing spaces
92             my ($rune, @samples) = split /\s+/, $desc;
93             die $originalDesc if not $rune;
94             push @dslAutoRules, doFixedRune( $rune, @samples );
95             }
96             my $dslAutoRules = join "\n", @dslAutoRules;
97              
98             # Assemble the base BSL
99             my $baseDSL = join "\n", $mainDSL, $glyphAutoRules, $dslAutoRules;
100              
101             my $defaultSemantics = <<'EOS';
102             # start and length will be needed for production
103             # :default ::= action => [name,start,length,values]
104             :default ::= action => [name,values]
105             lexeme default = latm => 1
106             EOS
107              
108             sub divergence {
109 0     0   0 die join '', 'Unrecoverable internal error: ', @_;
110             }
111              
112             # Given an input and an offset into that input,
113             # it reads a triple quote ('''). The return values
114             # are the parse value and a new offset in the input.
115             # Errors are thrown.
116              
117             sub getTripleQuote {
118 0     0   0 my ( $input, $offset ) = @_;
119 0         0 my $input_length = length ${$input};
  0         0  
120 0         0 my $resume_pos;
121             my $this_pos;
122              
123 0         0 my $nextNL = index ${$input}, "\n", $offset;
  0         0  
124 0 0       0 if ($nextNL < 0) {
125 0         0 die join '', 'Newline missing after triple quotes: "', ${$input}, '"'
  0         0  
126             }
127 0         0 my $initiator = substr ${$input}, $offset, $nextNL-$offset;
  0         0  
128 0 0 0     0 if ($initiator ne "'''" and $initiator !~ m/^''' *::/) {
129 0         0 die join '', 'Disallowed characters after initial triple quotes: "', $initiator, '"'
130             }
131              
132 0         0 pos ${$input} = $offset;
  0         0  
133 0         0 my ($indent) = ${$input} =~ /\G( *)[^ ]/g;
  0         0  
134 0         0 my $terminator = $indent . "'''";
135              
136 0         0 my $terminatorPos = index ${$input}, $terminator, $nextNL;
  0         0  
137 0         0 my $value = substr ${$input}, $nextNL+1, ($terminatorPos - $nextNL);
  0         0  
138              
139 0 0       0 say STDERR "Left main READ loop" if $MarpaX::Hoonlint::YAHC::DEBUG;
140              
141             # Return ref to value and new offset
142 0         0 return \$value, $terminatorPos + length $terminator;
143             }
144              
145             # Given an input and an offset into that input,
146             # it reads a triple double quote ("""). The return values
147             # are the parse value and a new offset in the input.
148             # Errors are thrown.
149              
150             # TODO: Needs to implement reading of sump(5d)
151              
152             sub getTripleDoubleQuote {
153 0     0   0 my ( $input, $offset ) = @_;
154 0         0 my $input_length = length ${$input};
  0         0  
155 0         0 my $resume_pos;
156             my $this_pos;
157              
158 0         0 my $nextNL = index ${$input}, "\n", $offset;
  0         0  
159 0 0       0 if ($nextNL < 0) {
160             die join '', 'Newline missing after triple double quotes: "',
161 0         0 ${$input}, '"'
  0         0  
162             }
163 0         0 my $initiator = substr ${$input}, $offset, $nextNL-$offset;
  0         0  
164 0 0       0 if ($initiator ne q{"""}) {
165 0         0 die join '',
166             'Disallowed characters after initial triple double quotes: "', $initiator, '"'
167             }
168              
169 0         0 pos ${$input} = $offset;
  0         0  
170 0         0 my ($indent) = ${$input} =~ /\G( *)[^ ]/g;
  0         0  
171 0         0 my $terminator = $indent . q{"""};
172              
173 0         0 my $terminatorPos = index ${$input}, $terminator, $nextNL;
  0         0  
174 0         0 my $value = substr ${$input}, $nextNL+1, ($terminatorPos - $nextNL);
  0         0  
175              
176 0 0       0 say STDERR "Left main READ loop" if $MarpaX::Hoonlint::YAHC::DEBUG;
177              
178             # Return ref to value and new offset
179 0         0 return \$value, $terminatorPos + length $terminator;
180             }
181              
182             # Given an input and an offset into that input,
183             # it reads unmarkdown. The return values
184             # are the parse value and a new offset in the input.
185             # Reading is not intelligent -- it finds a terminator, and
186             # treats the unmarkdown as a string.
187             # Errors are thrown.
188              
189             sub getCram {
190             # $DB::single = 1;
191              
192 0     0   0 my ( $input, $origOffset ) = @_;
193 0         0 my $input_length = length ${$input};
  0         0  
194 0         0 my $resume_pos;
195             my $this_pos;
196              
197 0         0 my $semiPos = rindex ${$input}, ';', $origOffset;
  0         0  
198 0         0 my $previousNlPos = rindex ${$input}, "\n", $semiPos;
  0         0  
199 0         0 my $indent = $semiPos - ($previousNlPos + 1);
200 0         0 my $firstNlPos = index ${$input}, "\n", $semiPos;
  0         0  
201 0         0 my $valueStartPos = $semiPos + 2;
202 0         0 my $nextNlPos = $firstNlPos;
203             # say STDERR qq{origOffset: }, substr(${$input}, $origOffset, 20);
204             # say STDERR qq{First NL pos: }, substr(${$input}, $firstNlPos, 20);
205              
206 0 0       0 if ($indent <= 0) {
207             # say STDERR "indent=$indent; nextNlPos=$nextNlPos";
208 0         0 LINE: while ($nextNlPos >= 0) {
209 0         0 pos ${$input} = $nextNlPos + 1;
  0         0  
210 0 0       0 if ( ${$input} =~ m/\G [ ]* == [\n]/xms ) {
  0         0  
211 0         0 my $terminatorStartPos = $LAST_MATCH_START[0];
212 0         0 my $terminatorEndPos = $LAST_MATCH_END[0];
213 0         0 my $value = substr( ${$input}, $valueStartPos,
  0         0  
214             $terminatorStartPos - $valueStartPos );
215 0         0 return \$value, $nextNlPos;
216             }
217 0         0 $nextNlPos = index ${$input}, "\n", $nextNlPos+1;
  0         0  
218             }
219             # If here, end of string is EOF
220 0         0 my $inputLength = length ${$input};
  0         0  
221 0         0 my $value = substr ${$input}, $valueStartPos, $inputLength - $valueStartPos;
  0         0  
222 0         0 return \$value, $inputLength;
223             }
224              
225             # If here, indent > 0
226 0         0 my $indentString = (' ' x $indent);
227              
228 0         0 LINE: while ($nextNlPos >= 0) {
229             # say STDERR "LINE: indent=$indent; nextNlPos=$nextNlPos";
230 0         0 pos ${$input} = $nextNlPos + 1;
  0         0  
231             # say STDERR qq{Pos set to: }, substr(${$input}, $nextNlPos+1, 20);
232 0 0       0 if ( ${$input} =~ m/\G $indentString [ ]* == [\n]/xms ) {
  0         0  
233 0         0 my $terminatorStartPos = $LAST_MATCH_START[0];
234             # say STDERR qq{TISTIS found: }, substr(${$input}, $terminatorStartPos, 20);
235 0         0 my $value = substr( ${$input}, $valueStartPos,
  0         0  
236             $terminatorStartPos - $valueStartPos );
237             # Continue parsing after TISTIS? Or before?
238 0         0 return \$value, $nextNlPos;
239             }
240            
241 0 0       0 if ( (substr ${$input}, $nextNlPos+1, $indent) eq $indentString ) {
  0         0  
242 0         0 $nextNlPos = index ${$input}, "\n", $nextNlPos+1;
  0         0  
243             # say STDERR qq{Continuing cram, nextNlPos=$nextNlPos};
244             # say STDERR qq{Continuing cram: }, substr(${$input}, $nextNlPos, 20);
245 0         0 next LINE;
246             }
247             # If here, outdent
248             # say STDERR qq{Outdent, returning at: }, substr(${$input}, $nextNlPos+1, 20);
249 0         0 my $value = substr ${$input}, $valueStartPos,
  0         0  
250             ($nextNlPos + 1) - $valueStartPos;
251 0         0 return \$value, $nextNlPos+1;
252             }
253              
254             # Premature EOF if here
255 0         0 return;
256             }
257              
258             # The 'semantics' named argument must be considered "internal"
259             # for now -- any change in the grammar could break any or all of
260             # apps. When the grammar can be frozen, the 'semantics' argument
261             # can become a "documented" feature.
262             #
263             # In the meantime, applications which want stability can simply
264             # copy in this file lexically, losing the advantage of updates,
265             # but guaranteeing stability.
266             sub new {
267 0     0   0 my ($class, @argHashes) = @_;
268 0         0 my $self = {};
269 0         0 for my $argHash (@argHashes) {
270 0         0 ARG_NAME: for my $argName ( keys %{$argHash} ) {
  0         0  
271 0 0       0 if ( $argName eq 'all_symbols' ) {
272 0         0 $self->{all_symbols} = $argHash->{all_symbols};
273 0         0 next ARG_NAME;
274             }
275 0 0       0 if ( $argName eq 'semantics' ) {
276 0         0 $self->{semantics} = $argHash->{semantics};
277 0         0 next ARG_NAME;
278             }
279 0         0 die "MarpaX::Hoonlint::YAHC::new() called with unknown arg name: $argName";
280             }
281             }
282 0   0     0 my $semantics = $self->{semantics} // $defaultSemantics;
283 0 0       0 if ( $self->{all_symbols} ) {
284             ## show all symbols
285 0         0 $baseDSL =~ s/[(][-] //g;
286 0         0 $baseDSL =~ s/ [-][)]//g;
287             }
288             else {
289             ## hide selected symbols
290 0         0 $baseDSL =~ s/[(][-] /(/g;
291 0         0 $baseDSL =~ s/ [-][)]/)/g;
292             }
293 0         0 my $dsl = $semantics . $baseDSL;
294              
295 0         0 my $grammar = Marpa::R2::Scanless::G->new( { source => \$dsl } );
296 0         0 $self->{dsl} = $dsl;
297 0         0 $self->{grammar} = $grammar;
298 0         0 return bless $self, $class;
299             }
300              
301             sub recceStart {
302 0     0   0 my ($self) = @_;
303 0         0 my $debug = $MarpaX::Hoonlint::YAHC::DEBUG;
304             my $recce = Marpa::R2::Scanless::R->new(
305             {
306             grammar => $self->{grammar},
307 0 0       0 ranking_method => 'high_rule_only',
    0          
308             trace_lexers => ( $debug ? 1 : 0 ),
309             trace_terminals => ( $debug ? 1 : 0 ),
310             }
311             );
312 0         0 $self->{recce} = $recce;
313 0         0 return $self;
314             }
315              
316             sub dsl {
317 0     0   0 my ($self) = @_;
318 0         0 return $self->{dsl};
319             }
320              
321             sub rawGrammar {
322 0     0   0 my ($self) = @_;
323 0         0 return $self->{grammar};
324             }
325              
326             sub rawRecce {
327 0     0   0 my ($self) = @_;
328 0         0 return $self->{recce};
329             }
330              
331             sub read {
332 0     0   0 my ($self, $input) = @_;
333 0         0 $self->recceStart();
334 0         0 my $recce = $self->{recce};
335 0         0 my $debug = $MarpaX::Hoonlint::YAHC::DEBUG;
336 0         0 my $input_length = length ${$input};
  0         0  
337 0         0 my $this_pos;
338 0         0 my $ok = eval { $this_pos = $recce->read( $input ) ; 1; };
  0         0  
  0         0  
339 0 0       0 if (not $ok) {
340 0 0       0 say STDERR $recce->show_progress(0, -1) if $debug;
341 0         0 die $EVAL_ERROR;
342             }
343              
344             # The main read loop. Read starting at $offset.
345             # If interrupted execute the handler logic,
346             # and, possibly, resume.
347 0 0       0 say STDERR "this_pos=$this_pos ; input_length=$input_length" if $debug;
348              
349             READ:
350 0         0 while ( $this_pos < $input_length ) {
351              
352 0         0 my $resume_pos;
353              
354             # Only one event at a time is expected -- more
355             # than one is an error. No event means parsing
356             # is exhausted.
357              
358 0         0 my $events = $recce->events();
359 0         0 my $event_count = scalar @{$events};
  0         0  
360 0 0       0 if ( $event_count < 0 ) {
361 0         0 last READ;
362             }
363 0 0       0 if ( $event_count != 1 ) {
364 0         0 divergence("One event expected, instead got $event_count");
365             }
366              
367             # Find the event name
368              
369 0         0 my $event = $events->[0];
370 0         0 my $eventName = $event->[0];
371              
372 0 0       0 say STDERR "$eventName event" if $MarpaX::Hoonlint::YAHC::DEBUG;
373              
374 0 0       0 if ( $eventName eq 'tripleQuote' ) {
375 0         0 my $value_ref;
376 0         0 ( $value_ref, $resume_pos ) = getTripleQuote( $input, $this_pos );
377 0 0       0 return if not $value_ref;
378             my $result = $recce->lexeme_read(
379             'TRIPLE_QUOTE_STRING',
380             $this_pos,
381 0         0 ( length ${$value_ref} ),
382 0         0 [ ${$value_ref} ]
  0         0  
383             );
384 0 0       0 say STDERR "lexeme_read('TRIPLE_QUOTE_STRING',...) returned ",
385             Data::Dumper::Dumper( \$result )
386             if $MarpaX::Hoonlint::YAHC::DEBUG;
387             }
388              
389             # TODO: tripeDoubleQuote must allow sump(5d)
390 0 0       0 if ( $eventName eq 'tripleDoubleQuote' ) {
391 0         0 my $value_ref;
392 0         0 ( $value_ref, $resume_pos )
393             = getTripleDoubleQuote( $input, $this_pos );
394 0 0       0 return if not $value_ref;
395             my $result = $recce->lexeme_read(
396             'TRIPLE_DOUBLE_QUOTE_STRING',
397             $this_pos,
398 0         0 ( length ${$value_ref} ),
399 0         0 [ ${$value_ref} ]
  0         0  
400             );
401 0 0       0 say STDERR "lexeme_read('TRIPLE_DOUBLE_QUOTE_STRING',...) returned ",
402             Data::Dumper::Dumper( \$result )
403             if $MarpaX::Hoonlint::YAHC::DEBUG;
404             }
405              
406 0 0       0 if ( $eventName eq '^CRAM' ) {
407 0         0 my $value_ref;
408 0         0 ( $value_ref, $resume_pos )
409             = getCram( $input, $this_pos );
410 0 0       0 if (not $value_ref) {
411             # TODO: After development, add "if $debug"
412 0         0 say STDERR $recce->show_progress( 0, -1 );
413 0         0 my $badStart = substr ${$input}, $this_pos, 50;
  0         0  
414 0         0 die join '', 'Problem in getCram: "', $badStart, '"';
415             }
416             my $result = $recce->lexeme_read(
417             'CRAM',
418             $this_pos,
419 0         0 ( length ${$value_ref} ),
420 0         0 [ ${$value_ref} ]
  0         0  
421             );
422 0 0       0 say STDERR "lexeme_read('CRAM',...) returned ",
423             Data::Dumper::Dumper( \$result )
424             if $MarpaX::Hoonlint::YAHC::DEBUG;
425             }
426              
427 0 0       0 if (not $resume_pos) {
428 0         0 die "read() ended prematurely\n",
429             " input length = $input_length\n",
430             " length read = $this_pos\n",
431             qq{ the cause was an "$eventName" event};
432             }
433              
434 0 0       0 say STDERR "this_pos=$this_pos ; input_length=$input_length" if $debug;
435              
436             # say STDERR qq{Resuming at "}, substr ${$input}, $resume_pos, 50;
437              
438 0         0 my $ok = eval { $this_pos = $recce->resume($resume_pos); 1; };
  0         0  
  0         0  
439 0 0       0 if ( not $ok ) {
440 0 0       0 say STDERR $recce->show_progress( 0, -1 ) if $debug;
441 0         0 die $EVAL_ERROR;
442             }
443              
444             }
445 0         0 return;
446             }
447              
448             sub parse {
449 0     0   0 my ($input) = @_;
450 0         0 my $debug = $MarpaX::Hoonlint::YAHC::DEBUG;
451 0         0 my $self = MarpaX::Hoonlint::YAHC->new();
452 0         0 $self->read($input);
453 0         0 my $recce = $self->{recce};
454              
455 0         0 if ( 0 ) {
456             # if ( $recce->ambiguity_metric() > 1 ) {
457              
458             # The calls in this section are experimental as of Marpa::R2 2.090
459             my $asf = Marpa::R2::ASF->new( { slr => $recce } );
460             say STDERR 'No ASF' if not defined $asf;
461             my $ambiguities = Marpa::R2::Internal::ASF::ambiguities($asf);
462             my @ambiguities = grep { defined } @{$ambiguities}[ 0 .. 1 ];
463             die
464             "Parse of BNF/Scanless source is ambiguous\n",
465             Marpa::R2::Internal::ASF::ambiguities_show( $asf, \@ambiguities );
466             } ## end if ( $recce->ambiguity_metric() > 1 )
467             # }
468              
469 0         0 my $valueRef = $recce->value();
470 0 0       0 if ( !$valueRef ) {
471 0 0       0 say STDERR $recce->show_progress( 0, -1 ) if $debug;
472 0         0 die "input read, but there was no parse";
473             }
474              
475 0         0 return $valueRef;
476             }
477              
478             # Takes one argument and returns a ref to an array of acceptable
479             # nodes. The array may be empty. All scalars are acceptable
480             # leaf nodes. Acceptable interior nodes have length at least 1.
481             sub prune {
482 1     1   3125 no warnings 'recursion';
  1         3  
  1         760  
483 0     0   0 my ($v) = @_;
484              
485 0         0 state $deleteIfEmpty = {
486             optKets => 1,
487             };
488              
489 0         0 state $nonSemantic = {
490             doubleStringElements => 1,
491             fordFile => 1,
492             fordHoop => 1,
493             fordHoopSeq => 1,
494             hoonExpression => 1,
495             wideLong5d => 1,
496             norm5d => 1,
497             norm5dMold => 1,
498             rope5d => 1,
499             rump5d => 1,
500             scad5d => 1,
501             scat5d => 1,
502             tall5d => 1,
503             tall5dSeq => 1,
504             teakChoice => 1,
505             till5d => 1,
506             till5dSeq => 1,
507             togaElements => 1,
508             wedeFirst => 1,
509             wide5d => 1,
510             wide5dChoices => 1,
511             wide5dJog => 1,
512             wide5dJogging => 1,
513             wide5dJogs => 1,
514             wide5dSeq => 1,
515             wideNorm5d => 1,
516             wideNorm5dMold => 1,
517             wideTeakChoice => 1,
518             wyde5d => 1,
519             wyde5dSeq => 1,
520             };
521              
522 0 0       0 return [] if not defined $v;
523 0         0 my $reftype = ref $v;
524 0 0       0 return [$v] if not $reftype; # An acceptable leaf node
525 0 0       0 return prune($$v) if $reftype eq 'REF';
526 0 0       0 divergence("Tree node has reftype $reftype") if $reftype ne 'ARRAY';
527 0         0 my @source = grep { defined } @{$v};
  0         0  
  0         0  
528 0         0 my $element_count = scalar @source;
529 0 0       0 return [] if $element_count <= 0; # must have at least one element
530 0         0 my $name = shift @source;
531 0         0 my $nameReftype = ref $name;
532             # divergence("Tree node name has reftype $nameReftype") if $nameReftype;
533 0 0       0 if ($nameReftype) {
534 0         0 my @result = ();
535 0         0 ELEMENT:for my $element ($name, @source) {
536 0 0       0 if (ref $element eq 'ARRAY') {
537 0         0 push @result, grep { defined }
538 0         0 map { @{$_}; }
  0         0  
539 0         0 map { prune($_); }
540 0         0 @{$element}
  0         0  
541             ;
542 0         0 next ELEMENT;
543             }
544 0         0 push @result, $_;
545             }
546 0         0 return [@result];
547             }
548 0 0 0     0 if (defined $deleteIfEmpty->{$name} and $element_count == 1) {
549 0         0 return [];
550             }
551 0 0       0 if (defined $nonSemantic->{$name}) {
552             # Not an acceptable branch node, but (hopefully)
553             # its children are acceptable
554 0         0 return [ grep { defined }
555 0         0 map { @{$_}; }
  0         0  
556 0         0 map { prune($_); }
  0         0  
557             @source
558             ];
559             }
560              
561             # An acceptable branch node
562 0         0 my @result = ($name);
563 0         0 push @result, grep { defined }
564 0         0 map { @{$_}; }
  0         0  
565 0         0 map { prune($_); }
  0         0  
566             @source;
567 0         0 return [\@result];
568             }
569              
570             # takes LC alphanumeric rune name and samples
571             # for N-fixed rune and returns the Marpa rules
572             # for the tall and the 2 regular wide forms.
573             sub doFixedRune {
574 70     70   135 my ($runeName, @samples) = @_;
575 70         142 my @result = (join ' ', '#', (uc $runeName), @samples);
576 70         104 my $glyphName1 = substr($runeName, 0, 3);
577 70         81 my $glyphName2 = substr($runeName, 3, 3);
578 70 50       117 my $glyph1 = $glyphs{$glyphName1} or die "no glyph for $glyphName1";
579 70         102 my $glyph2 = $glyphs{$glyphName2};
580 70         89 my $glyphLexeme1 = ($glyphName1) . '4h';
581 70         83 my $glyphLexeme2 = ($glyphName2) . '4h';
582 70         98 my $tallLHS = 'tall' . ucfirst $runeName;
583 70         88 my $wideLHS = 'wide' . ucfirst $runeName;
584 70         88 my $tallRuneLexeme = (uc $runeName) . 'GAP';
585 70         117 my $wideRuneLexeme = (uc $runeName) . 'PEL';
586              
587             # norm5d ::= tallBarhep
588 70         96 push @result, 'norm5d ::= ' . $tallLHS;
589              
590             # wideNorm5d ::= wideBarhep
591 70         77 push @result, 'wideNorm5d ::= ' . $wideLHS;
592              
593             # tallBarhep ::= (- BAR4H HEP4H GAP -) tall5d (- GAP -) tall5d
594 70         187 push @result, $tallLHS . ' ::= (- '
595             . $tallRuneLexeme
596             . ' -) ' . (join ' (- GAP -) ', @samples);
597 70         81 state $wideEquiv = {
598             bont5d => 'wideBont5d',
599             bonz5d => 'wideBonz5d',
600             mold => 'wyde5d',
601             tall5d => 'wide5d',
602             rack5d => 'wideRack5d',
603             rick5d => 'wideRick5d',
604             ruck5d => 'wideRuck5d',
605             teak5d => 'wideTeak5d',
606             };
607 70   66     94 my @wideSamples = map { $wideEquiv->{$_} // $_; } @samples;
  145         412  
608              
609             # wideBarhep ::= (- BARHEPPEL -) wide5d (- ACE -) wide5d (- PER -)
610 70         135 push @result, $wideLHS . ' ::= (- '
611             . $wideRuneLexeme
612             . ' -) ' . (join ' (- ACE -) ', @wideSamples) . q{ (- PER -)};
613              
614             # BARHEPGAP ~ bar4h hep4h gap4k
615             # BARHEPPEL ~ bar4h hep4h pel4h
616 70         108 push @result, "$tallRuneLexeme ~ $glyphLexeme1 $glyphLexeme2 gap4k";
617 70         96 push @result, "$wideRuneLexeme ~ $glyphLexeme1 $glyphLexeme2 pel4h";
618              
619 70         340 return join "\n", @result, '';
620             }
621              
622             1;
623              
624             # The "FIXED:" comments lines are descriptons of the fixed length runes
625             # (1-fixed, 2-fixed, 3-fixed and 4-fixed) for auto-generation
626             # of Marpa rules for the various regular formats, both
627             # tall and wide.
628             #
629             # The format is
630             #
631             # rune type1 type2 ...
632              
633             # Organization is by hoon.hoon (and Hoon Library) sections: 4a, 5d, etc.;
634             # and within that alphabetically by "face" name
635              
636             __DATA__