File Coverage

blib/lib/MarpaX/Hoonlint.pm
Criterion Covered Total %
statement 69 515 13.4
branch 12 146 8.2
condition 0 30 0.0
subroutine 13 50 26.0
pod 0 37 0.0
total 94 778 12.0


line stmt bran cond sub pod time code
1             # Hoon "tidy" utility
2              
3 1     1   679 use 5.010;
  1         4  
4 1     1   5 use strict;
  1         42  
  1         30  
5 1     1   6 use warnings;
  1         2  
  1         26  
6 1     1   5 no warnings 'recursion';
  1         1  
  1         51  
7              
8             package MarpaX::Hoonlint;
9              
10 1     1   641 use Data::Dumper;
  1         7016  
  1         62  
11 1     1   7 use English qw( -no_match_vars );
  1         2  
  1         11  
12 1     1   439 use Scalar::Util qw(looks_like_number weaken);
  1         2  
  1         51  
13 1     1   829 use Getopt::Long;
  1         10584  
  1         5  
14              
15 1     1   879 use MarpaX::Hoonlint::yahc;
  1         5  
  1         56  
16              
17 1     1   7 use vars qw($VERSION $STRING_VERSION @ISA $DEBUG);
  1         2  
  1         282  
18             $VERSION = '1.009_001';
19             $STRING_VERSION = $VERSION;
20             ## no critic (BuiltinFunctions::ProhibitStringyEval)
21             $VERSION = eval $VERSION;
22             ## use critic
23             $DEBUG = 0;
24              
25             my %separator = qw(
26             hyf4jSeq DOT
27             singleQuoteCord gon4k
28             dem4k gon4k
29             timePeriodKernel DOT
30             optBonzElements GAP
31             optWideBonzElements ACE
32             till5dSeq GAP
33             wyde5dSeq ACE
34             gash5d FAS
35             togaElements ACE
36             wide5dJogs wide5dJoggingSeparator
37             rope5d DOT
38             rick5d GAP
39             wideRick5d commaAce
40             ruck5d GAP
41             wideRuck5d commaAce
42             tallTopKidSeq GAP_SEM
43             wideInnerTops ACE
44             wideAttrBody commaAce
45             scriptStyleTailElements GAP
46             moldInfixCol2 COL
47             lusSoilSeq DOG4I
48             hepSoilSeq DOG4I
49             infixDot DOG4I
50             waspElements GAP
51             whap5d GAP
52             hornSeq GAP
53             wideHornSeq ACE
54             fordHoopSeq GAP
55             tall5dSeq GAP
56             wide5dSeq ACE
57             fordFascomElements GAP
58             optFordHithElements FAS
59             fordHoofSeq commaWS
60             );
61              
62             sub internalError {
63 0     0 0 0 my ($instance) = @_;
64 0   0     0 my $fileName = $instance->{fileName} // "[No file name]";
65 0         0 my @pieces = ( "$PROGRAM_NAME $fileName: Internal Error\n", @_ );
66 0 0       0 push @pieces, "\n" unless $pieces[$#pieces] =~ m/\n$/;
67 0         0 my ( undef, $codeFilename, $codeLine ) = caller;
68 0         0 die join q{}, @pieces,
69             "Internal error was at $codeFilename, line $codeLine";
70             }
71              
72             sub doNode {
73 0     0 0 0 my ( $instance, @argChildren ) = @_;
74 0         0 my $pSource = $instance->{pHoonSource};
75 0         0 my @results = ();
76 0         0 my $childCount = scalar @argChildren;
77 1     1   9 no warnings 'once';
  1         8  
  1         42  
78 0         0 my $ruleID = $Marpa::R2::Context::rule;
79 1     1   5 use warnings;
  1         2  
  1         5436  
80             my ( $lhs, @rhs ) =
81 0         0 map { $MarpaX::Hoonlint::grammar->symbol_display_form($_) }
  0         0  
82             $MarpaX::Hoonlint::grammar->rule_expand($ruleID);
83 0         0 my ( $first_g1, $last_g1 ) = Marpa::R2::Context::location();
84 0         0 my ($lhsStart) =
85             $MarpaX::Hoonlint::recce->g1_location_to_span( $first_g1 + 1 );
86              
87 0         0 my $node;
88             CREATE_NODE: {
89 0 0       0 if ( $childCount <= 0 ) {
  0         0  
90 0         0 $node = {
91             type => 'null',
92             symbol => $lhs,
93             start => $lhsStart,
94             length => 0,
95             };
96 0         0 last CREATE_NODE;
97             }
98 0         0 my ( $last_g1_start, $last_g1_length ) =
99             $MarpaX::Hoonlint::recce->g1_location_to_span($last_g1);
100 0         0 my $lhsLength = $last_g1_start + $last_g1_length - $lhsStart;
101             RESULT: {
102 0         0 CHILD: for my $childIX ( 0 .. $#argChildren ) {
  0         0  
103 0         0 my $child = $argChildren[$childIX];
104 0         0 my $refType = ref $child;
105 0 0       0 next CHILD unless $refType eq 'ARRAY';
106              
107 0         0 my ( $lexemeStart, $lexemeLength, $lexemeName ) = @{$child};
  0         0  
108              
109 0 0       0 if ( $lexemeName eq 'TRIPLE_DOUBLE_QUOTE_STRING' ) {
110 0         0 my $terminator = q{"""};
111 0         0 my $terminatorPos = index ${$pSource},
  0         0  
112             $terminator,
113             $lexemeStart + $lexemeLength;
114 0         0 $lexemeLength =
115             $terminatorPos + ( length $terminator ) - $lexemeStart;
116             }
117 0 0       0 if ( $lexemeName eq 'TRIPLE_QUOTE_STRING' ) {
118 0         0 my $terminator = q{'''};
119 0         0 my $terminatorPos = index ${$pSource},
  0         0  
120             $terminator,
121             $lexemeStart + $lexemeLength;
122 0         0 $lexemeLength =
123             $terminatorPos + ( length $terminator ) - $lexemeStart;
124             }
125 0         0 $argChildren[$childIX] = {
126             type => 'lexeme',
127             start => $lexemeStart,
128             length => $lexemeLength,
129             symbol => $lexemeName,
130             };
131             }
132              
133 0         0 my $lastLocation = $lhsStart;
134 0 0       0 if ( ( scalar @rhs ) != $childCount ) {
135              
136             # This is a non-trivial (that is, longer than one item) sequence rule.
137 0         0 my $childIX = 0;
138 0         0 my $lastSeparator;
139 0         0 CHILD: for ( ; ; ) {
140              
141 0         0 my $child = $argChildren[$childIX];
142 0         0 my $childType = $child->{type};
143 0         0 $childIX++;
144             ITEM: {
145 0 0       0 if ( defined $lastSeparator ) {
  0         0  
146             my $length =
147 0         0 $child->{start} - $lastSeparator->{start};
148 0         0 $lastSeparator->{length} = $length;
149             }
150 0         0 push @results, $child;
151 0         0 $lastLocation = $child->{start} + $child->{length};
152             }
153 0 0       0 last RESULT if $childIX > $#argChildren;
154 0         0 my $separator = $separator{$lhs};
155 0 0       0 next CHILD unless $separator;
156 0         0 $lastSeparator = {
157             type => 'separator',
158             symbol => $separator,
159             start => $lastLocation,
160              
161             # length supplied later
162             };
163 0         0 push @results, $lastSeparator;
164             }
165 0         0 last RESULT;
166             }
167              
168             # All other rules
169 0         0 CHILD: for my $childIX ( 0 .. $#argChildren ) {
170 0         0 my $child = $argChildren[$childIX];
171 0         0 push @results, $child;
172             }
173             }
174              
175             $node = {
176 0         0 type => 'node',
177             ruleID => $ruleID,
178             start => $lhsStart,
179             length => $lhsLength,
180             children => \@results,
181             };
182             }
183              
184             # Add weak links
185 0         0 my $children = $node->{children};
186 0 0 0     0 if ( $children and scalar @{$children} >= 1 ) {
  0         0  
187 0         0 CHILD: for my $childIX ( 0 .. $#$children ) {
188 0         0 my $child = $children->[$childIX];
189 0         0 $child->{PARENT} = $node;
190 0         0 weaken( $child->{PARENT} );
191             }
192 0         0 CHILD: for my $childIX ( 1 .. $#$children ) {
193 0         0 my $thisChild = $children->[$childIX];
194 0         0 my $prevChild = $children->[ $childIX - 1 ];
195 0         0 $thisChild->{PREV} = $prevChild;
196 0         0 weaken( $thisChild->{PREV} );
197 0         0 $prevChild->{NEXT} = $thisChild;
198 0         0 weaken( $prevChild->{NEXT} );
199             }
200             }
201              
202 0         0 my $nodeCount = $instance->{nodeCount};
203 0         0 $node->{IX} = $nodeCount;
204 0         0 $instance->{nodeCount} = $nodeCount + 1;
205              
206 0         0 return $node;
207             }
208              
209             sub describeRange {
210 0     0 0 0 my ( $firstLine, $firstColumn, $lastLine, $lastColumn ) = @_;
211 0 0       0 return sprintf "@%d:%d-%d:%d", $firstLine, $firstColumn, $lastLine,
212             $lastColumn
213             if $firstLine != $lastLine;
214 0 0       0 return sprintf "@%d:%d-%d", $firstLine, $firstColumn, $lastColumn
215             if $firstColumn != $lastColumn;
216 0         0 return sprintf "@%d:%d", $firstLine, $firstColumn;
217             }
218              
219             sub describeNodeRange {
220 0     0 0 0 my ( $instance, $node ) = @_;
221 0         0 my $firstPos = $node->{start};
222 0         0 my $length = $node->{length};
223 0         0 my $lastPos = $firstPos + $length;
224 0         0 my ( $firstLine, $firstColumn ) = $instance->line_column($firstPos);
225 0         0 my ( $lastLine, $lastColumn ) = $instance->line_column($lastPos);
226 0         0 return describeRange( $firstLine, $firstColumn, $lastLine, $lastColumn );
227             }
228              
229             sub lexeme {
230 0     0 0 0 my ( $instance, $line, $column ) = @_;
231 0         0 my $literal = $instance->literalLine($line);
232 0         0 my $lexeme = substr $literal, $column;
233 0         0 $lexeme =~ s/[\s].*\z//xms;
234 0         0 return $lexeme;
235             }
236              
237             sub literalNode {
238 0     0 0 0 my ( $instance, $node ) = @_;
239 0         0 my $start = $node->{start};
240 0         0 my $length = $node->{length};
241 0         0 return $instance->literal( $start, $length );
242             }
243              
244             sub literalLine {
245 0     0 0 0 my ( $instance, $lineNum ) = @_;
246 0         0 my $lineToPos = $instance->{lineToPos};
247 0         0 my $startPos = $lineToPos->[$lineNum];
248 0 0       0 $DB::single = 1 if not defined $lineToPos->[ $lineNum + 1 ];
249 0         0 my $line =
250             $instance->literal( $startPos,
251             ( $lineToPos->[ $lineNum + 1 ] - $startPos ) );
252 0         0 return $line;
253             }
254              
255             sub literal {
256 0     0 0 0 my ( $instance, $start, $length ) = @_;
257 0         0 my $pSource = $instance->{pHoonSource};
258 0 0       0 return '' if $start >= length ${$pSource};
  0         0  
259 0         0 return substr ${$pSource}, $start, $length;
  0         0  
260             }
261              
262             sub column {
263 0     0 0 0 my ( $instance, $pos ) = @_;
264 0         0 my $pSource = $instance->{pHoonSource};
265 0         0 return $pos - ( rindex ${$pSource}, "\n", $pos - 1 );
  0         0  
266             }
267              
268             sub maxNumWidth {
269 0     0 0 0 my ($instance) = @_;
270 0         0 return length q{} . $#{ $instance->{lineToPos} };
  0         0  
271             }
272              
273             sub contextDisplay {
274 0     0 0 0 my ($instance) = @_;
275 0         0 my $pTopicLines = $instance->{topicLines};
276 0         0 my $pMistakeLines = $instance->{mistakeLines};
277 0         0 my $contextSize = $instance->{contextSize};
278 0         0 my $displayDetails = $instance->{displayDetails};
279 0         0 my $lineToPos = $instance->{lineToPos};
280 0         0 my @pieces = ();
281 0         0 my %tag = map { $_ => q{>} } keys %{$pTopicLines};
  0         0  
  0         0  
282 0         0 $tag{$_} = q{!} for keys %{$pMistakeLines};
  0         0  
283 0         0 my @sortedLines = sort { $a <=> $b } map { $_ + 0; } keys %tag;
  0         0  
  0         0  
284              
285             # say STDERR join " ", __FILE__, __LINE__, "# of sorted lines:", (scalar @sortedLines);
286             # say STDERR join " ", __FILE__, __LINE__, Data::Dumper::Dumper(\@sortedLines);
287             # say STDERR join " ", __FILE__, __LINE__, Data::Dumper::Dumper($pMistakeLines);
288             # say STDERR join " ", __FILE__, __LINE__, Data::Dumper::Dumper($lineToPos);
289              
290 0 0       0 if ( $contextSize <= 0 ) {
291 0         0 for my $lineNum (@sortedLines) {
292 0         0 my $mistakeDescs = $pMistakeLines->{$lineNum};
293 0         0 for my $mistakeDesc ( @{$mistakeDescs} ) {
  0         0  
294 0         0 my ( $mistake, $desc ) = @{$mistakeDesc};
  0         0  
295 0         0 push @pieces, $desc, "\n";
296             }
297             }
298 0         0 return join q{}, @pieces;
299             }
300              
301 0         0 my $maxNumWidth = $instance->maxNumWidth();
302 0         0 my $lineNumFormat = q{%} . $maxNumWidth . 'd';
303              
304             # Add to @pieces a set of lines to be displayed consecutively
305             my $doConsec = sub () {
306 0     0   0 my ( $start, $end ) = @_;
307 0 0       0 $start = 1 if $start < 1;
308 0 0       0 $end = $#$lineToPos - 1 if $end >= $#$lineToPos;
309 0         0 for my $lineNum ( $start .. $end ) {
310 0         0 my $startPos = $lineToPos->[$lineNum];
311 0         0 my $line = $instance->literalLine($lineNum);
312 0   0     0 my $tag = $tag{$lineNum} // q{ };
313 0         0 my $mistakeDescs = $pMistakeLines->{$lineNum};
314 0         0 for my $mistakeDesc ( @{$mistakeDescs} ) {
  0         0  
315 0         0 my ( $mistake, $desc ) = @{$mistakeDesc};
  0         0  
316 0         0 my $details = $mistake->{details};
317 0 0 0     0 if ( $details and scalar @{$details} and $displayDetails > 0 ) {
  0   0     0  
318 0         0 push @pieces, '[ ', $desc, "\n";
319              
320             # detail levels are not currently used, but are for future
321             # extensions.
322 0         0 for my $detailLevel ( @{$details} ) {
  0         0  
323 0         0 for my $detail ( @{$detailLevel} ) {
  0         0  
324 0         0 push @pieces, q{ }, $detail, "\n";
325             }
326             }
327 0         0 push @pieces, "]\n";
328             }
329             else {
330 0         0 push @pieces, '[ ', $desc, " ]\n";
331             }
332             }
333 0         0 push @pieces, ( sprintf $lineNumFormat, $lineNum ), $tag, q{ },
334             $line;
335             }
336 0         0 };
337              
338 0         0 my $lastIX = -1;
339 0         0 CONSEC_RANGE: while ( $lastIX < $#sortedLines ) {
340 0         0 my $firstIX = $lastIX + 1;
341              
342             # Divider line if after first consecutive range
343 0 0       0 push @pieces, ( '-' x ( $maxNumWidth + 2 ) ), "\n" if $firstIX > 0;
344 0         0 $lastIX = $firstIX;
345 0         0 SET_LAST_IX: while (1) {
346 0         0 my $nextIX = $lastIX + 1;
347 0 0       0 last SET_LAST_IX if $nextIX > $#sortedLines;
348              
349             # We combine lines if by doing so, we make the listing shorter.
350             # This is calculated by
351             # 1.) Taking the current last line.
352             # 2.) Add the context lines for the last and next lines (2*($contextSize-1))
353             # 3.) Adding 1 for the divider line, which we save if we combine ranges.
354             # 4.) Adding 1 because we test if they abut, not overlap
355             # Doing the arithmetic, we get
356             last SET_LAST_IX
357 0 0       0 if $sortedLines[$lastIX] + 2 * $contextSize <
358             $sortedLines[$nextIX];
359 0         0 $lastIX = $nextIX;
360             }
361 0         0 $doConsec->(
362             $sortedLines[$firstIX] - ( $contextSize - 1 ),
363             $sortedLines[$lastIX] + ( $contextSize - 1 )
364             );
365             }
366              
367 0         0 return join q{}, @pieces;
368             }
369              
370             # Set lists of topic and mistake lines in instance
371             sub reportItem {
372 0     0 0 0 my ( $instance, $mistake, $mistakeDesc, $topicLineArg, $mistakeLineArg ) =
373             @_;
374              
375 0         0 my $inclusions = $instance->{inclusions};
376 0         0 my $suppressions = $instance->{suppressions};
377 0         0 my $reportPolicy = $mistake->{policy};
378              
379             # TODO: Is subpolicy everywhere? Can the tag
380             # named argument be eliminated?
381 0         0 my $mistakeSubpolicy = $mistake->{subpolicy};
382              
383             # TODO: Change subpolicy to ALWAYS be an array
384             # and eliminate the following code
385 0         0 my @reportSubpolicy = ();
386             SET_SUBPOLICY: {
387 0         0 my $refType = ref $mistakeSubpolicy;
  0         0  
388 0 0       0 if ($refType eq 'ARRAY') {
389 0         0 push @reportSubpolicy, @{$mistakeSubpolicy};
  0         0  
390 0         0 last SET_SUBPOLICY;
391             }
392 0         0 push @reportSubpolicy, $mistakeSubpolicy;
393             }
394 0         0 my $reportSubpolicy = join ':', @reportSubpolicy;
395              
396             # TODO: Usually a default of parentLine, parentColumn has already
397             # been enforced. This is a mistake and should change.
398             # Add reportLine/reportColumn to all mistakes, and do not use
399             # line/column. (Can line/column be eliminated?)
400 0   0     0 my $reportLine = $mistake->{reportLine} // $mistake->{line};
401 0   0     0 my $reportColumn = $mistake->{reportColumn} // $mistake->{column};
402 0         0 my $reportLC = join ':', $reportLine, $reportColumn + 1;
403 0         0 my $suppressThisItem = 0;
404 0         0 my $excludeThisItem = 0;
405              
406             $excludeThisItem = 1
407             if $inclusions
408 0 0 0     0 and not $inclusions->{$reportLC}{$reportPolicy}{$reportSubpolicy};
409             my $suppression =
410 0         0 $suppressions->{$reportLC}->{$reportPolicy}->{$reportSubpolicy};
411 0 0       0 if ( defined $suppression ) {
412 0         0 $suppressThisItem = 1;
413             $instance->{unusedSuppressions}->{$reportLC}->{$reportPolicy}
414 0         0 ->{$reportSubpolicy} = undef;
415             }
416              
417 0 0       0 return if $excludeThisItem;
418 0 0       0 return if $suppressThisItem;
419              
420 0         0 my $fileName = $instance->{fileName};
421 0         0 my $mistakeLines = $instance->{mistakeLines};
422              
423 0         0 my $topicLines = $instance->{topicLines};
424 0         0 my @topicLines = ();
425 0 0       0 push @topicLines, ref $topicLineArg ? @{$topicLineArg} : $topicLineArg;
  0         0  
426             push @topicLines,
427 0         0 grep { defined $_ }
428             ( $mistakeLineArg, $mistake->{line},
429 0         0 $mistake->{parentLine}, $reportLine );
430 0         0 for my $topicLine (@topicLines) {
431 0         0 $topicLines->{$topicLine} = 1;
432             }
433              
434 0         0 my $thisMistakeDescs = $mistakeLines->{$mistakeLineArg};
435 0 0       0 $thisMistakeDescs = [] if not defined $thisMistakeDescs;
436 0         0 push @{$thisMistakeDescs},
  0         0  
437             [
438             $mistake,
439             "$fileName $reportLC $reportPolicy $reportSubpolicy $mistakeDesc"
440             ];
441 0         0 $mistakeLines->{$mistakeLineArg} = $thisMistakeDescs;
442              
443             }
444              
445             sub lhsName {
446 0     0 0 0 my ( $instance, $node ) = @_;
447 0         0 my $grammar = $instance->{grammar};
448 0         0 my $type = $node->{type};
449 0 0       0 return if $type ne 'node';
450 0         0 my $ruleID = $node->{ruleID};
451 0         0 my ( $lhs, @rhs ) = $grammar->rule_expand($ruleID);
452 0         0 return $grammar->symbol_name($lhs);
453             }
454              
455             # The "symbol" of a node. Not necessarily unique.
456             sub symbol {
457 0     0 0 0 my ( $instance, $node ) = @_;
458             # local $Data::Dumper::Maxdepth = 1;
459             # say STDERR join " ", __FILE__, __LINE__, Data::Dumper::Dumper($node);
460 0         0 my $name = $node->{symbol};
461 0 0       0 return $name if defined $name;
462 0         0 my $type = $node->{type};
463 0 0       0 $DB::single = 1 if not $type;
464 0 0       0 die Data::Dumper::Dumper($node) if not $type;
465 0 0       0 return $instance->lhsName($node) if $type eq 'node';
466 0         0 return "[$type]";
467             }
468              
469             # Can be used as test of "brick-ness"
470             sub brickName {
471 0     0 0 0 my ( $instance, $node ) = @_;
472             # local $Data::Dumper::Maxdepth = 1;
473             # say STDERR join " ", __FILE__, __LINE__, Data::Dumper::Dumper($node);
474 0         0 my $type = $node->{type};
475 0 0       0 return $instance->symbol($node) if $type ne 'node';
476 0         0 my $lhsName = $instance->lhsName($node);
477 0 0       0 return $lhsName if not $instance->{mortarLHS}->{$lhsName};
478 0         0 return;
479             }
480              
481             # Return the name of a brick by recursively climbing,
482             # and die if this fails.
483             sub forceBrickName {
484 0     0 0 0 my ( $instance, $node ) = @_;
485 0         0 my $brickNode = $instance->brickNode($node);
486 0 0       0 return $instance->brickName($brickNode) if $brickNode;
487 0         0 $DB::single = 1;
488 0         0 die;
489             }
490              
491             # The name of a node for diagnostics purposes. Prefers
492             # "brick" symbols over "mortar" symbols.
493             sub diagName {
494 0     0 0 0 my ( $instance, $node ) = @_;
495 0         0 my $brickNode = $instance->brickNode($node);
496 0 0       0 return $instance->brickName($brickNode) if $brickNode;
497 0         0 return $instance->name($node);
498             }
499              
500             # The "name" of a node. Not necessarily unique
501             sub name {
502 0     0 0 0 my ( $instance, $node ) = @_;
503 0         0 my $type = $node->{type};
504 0         0 my $symbol = $instance->symbol($node);
505 0 0       0 return $symbol if $type ne 'node';
506 0         0 return $instance->lhsName($node);
507             }
508              
509             # Determine how many spaces we need.
510             # Arguments are an array of strings (intended
511             # to be concatenated) and an integer, representing
512             # the number of spaces needed by the app.
513             # (For hoon this will always between 0 and 2.)
514             # Hoon's notation of spacing, in which a newline is equivalent
515             # a gap and therefore two spaces, is used.
516             #
517             # Return value is the number of spaces needed after
518             # the trailing part of the argument string array is
519             # taken into account. It is always less than or
520             # equal to the `spacesNeeded` argument.
521             sub spacesNeeded {
522 0     0 0 0 my ( $strings, $spacesNeeded ) = @_;
523 0         0 for ( my $arrayIX = $#$strings ; $arrayIX >= 0 ; $arrayIX-- ) {
524              
525 0         0 my $string = $strings->[$arrayIX];
526              
527 0         0 for (
528             my $stringIX = ( length $string ) - 1 ;
529             $stringIX >= 0 ;
530             $stringIX--
531             )
532             {
533 0         0 my $char = substr $string, $stringIX, 1;
534 0 0       0 return 0 if $char eq "\n";
535 0 0       0 return $spacesNeeded if $char ne q{ };
536 0         0 $spacesNeeded--;
537 0 0       0 return 0 if $spacesNeeded <= 0;
538             }
539             }
540              
541             # No spaces needed at beginning of string;
542 0         0 return 0;
543             }
544              
545             sub testStyleCensus {
546 1     1 0 3 my ($instance) = @_;
547 1         3 my $ruleDB = $instance->{ruleDB};
548 1         3 my $symbolDB = $instance->{symbolDB};
549 1         2 my $symbolReverseDB = $instance->{symbolReverseDB};
550 1         3 my $grammar = $instance->{grammar};
551              
552             SYMBOL:
553 1         6 for my $symbolID ( $grammar->symbol_ids() ) {
554 801         1585 my $name = $grammar->symbol_name($symbolID);
555 801         14349 my $data = {};
556 801         1593 $data->{name} = $name;
557 801         1035 $data->{id} = $symbolID;
558 801         1019 $data->{lexeme} = 1; # default to lexeme
559 801 100       1375 $data->{gap} = 1 if $name eq 'GAP';
560 801 100       1497 if ( $name =~ m/^[B-Z][AEOIU][B-Z][B-Z][AEIOU][B-Z]GAP$/ ) {
561 72         117 $data->{gap} = 1;
562 72         102 $data->{runeGap} = 1;
563             }
564 801         1148 $symbolDB->[$symbolID] = $data;
565 801         1613 $symbolReverseDB->{$name} = $data;
566             }
567 1         52 my $gapID = $symbolReverseDB->{'GAP'}->{id};
568             RULE:
569 1         11 for my $ruleID ( $grammar->rule_ids() ) {
570 1102         2510 my $data = { id => $ruleID };
571 1102         2211 my ( $lhs, @rhs ) = $grammar->rule_expand($ruleID);
572 1102         29465 $data->{symbols} = [ $lhs, @rhs ];
573 1102         2183 my $lhsName = $grammar->symbol_name($lhs);
574 1102         20963 my $separatorName = $separator{$lhsName};
575 1102 100       1877 if ($separatorName) {
576 34         67 my $separatorID = $symbolReverseDB->{$separatorName}->{id};
577 34         61 $data->{separator} = $separatorID;
578 34 100       71 if ( $separatorID == $gapID ) {
579 11         22 $data->{gapiness} = -1;
580             }
581             }
582 1102 100       1992 if ( not defined $data->{gapiness} ) {
583 1091         1598 for my $rhsID (@rhs) {
584 2664 100       5756 $data->{gapiness}++ if $symbolDB->[$rhsID]->{gap};
585             }
586             }
587 1102         1555 $ruleDB->[$ruleID] = $data;
588              
589             # say STDERR join " ", __FILE__, __LINE__, "setting rule $ruleID gapiness to", $data->{gapiness} // 'undef';
590 1102         3332 $symbolReverseDB->{$lhs}->{lexeme} = 0;
591             }
592              
593             }
594              
595             sub gapNode {
596 0     0 0   my ( $instance, $node ) = @_;
597 0           my $symbolReverseDB = $instance->{symbolReverseDB};
598 0           my $symbol = $node->{symbol};
599 0 0         return if not defined $symbol;
600 0           return $symbolReverseDB->{$symbol}->{gap};
601             }
602              
603             sub runeGapNode {
604 0     0 0   my ( $instance, $node ) = @_;
605 0           my $symbolReverseDB = $instance->{symbolReverseDB};
606 0           my $symbol = $node->{symbol};
607 0 0         return if not defined $symbol;
608 0           return $symbolReverseDB->{$symbol}->{runeGap};
609             }
610              
611             # Assumes the node *is* a gap
612             sub gapLength {
613 0     0 0   my ( $instance, $node ) = @_;
614 0 0         if ( $instance->runeGapNode($node) ) {
615 0           my $gapLiteral = $instance->literalNode($node);
616 0           return (length $gapLiteral) - 2;
617             }
618 0           return $node->{length};
619             }
620              
621             sub line_column {
622 0     0 0   my ( $instance, $pos ) = @_;
623 0           $Data::Dumper::Maxdepth = 3;
624 0 0         die Data::Dumper::Dumper($instance) if not defined $instance->{recce};
625 0           my ( $line, $column ) = $instance->{recce}->line_column($pos);
626 0           $column--;
627 0           return $line, $column;
628             }
629              
630             sub ancestorByBrickName {
631 0     0 0   my ( $instance, $node, $name ) = @_;
632 0           my $thisNode = $node;
633 0           PARENT: while ($thisNode) {
634 0           my $thisName = $instance->brickName($thisNode);
635 0 0 0       return $thisNode if defined $thisName and $thisName eq $name;
636 0           $thisNode = $thisNode->{PARENT};
637             }
638 0           return;
639             }
640              
641             sub ancestorByLHS {
642 0     0 0   my ( $instance, $node, $names ) = @_;
643 0           my $thisNode = $node;
644 0           PARENT: while ($thisNode) {
645 0           my $thisName = $instance->lhsName($thisNode);
646 0 0 0       return $thisNode if defined $thisName and $names->{$thisName};
647 0           $thisNode = $thisNode->{PARENT};
648             }
649 0           return;
650             }
651              
652             sub ancestor {
653 0     0 0   my ( $instance, $node, $generations ) = @_;
654 0           my $thisNode = $node;
655 0           PARENT: while ($thisNode) {
656 0 0         return $thisNode if $generations <= 0;
657 0           $generations--;
658 0           $thisNode = $thisNode->{PARENT};
659             }
660 0           return;
661             }
662              
663             sub nodeLC {
664 0     0 0   my ( $instance, $node ) = @_;
665 0           return $instance->line_column( $node->{start} );
666             }
667              
668             sub brickNode {
669 0     0 0   my ( $instance, $node ) = @_;
670 0           my $thisNode = $node;
671 0           while ($thisNode) {
672 0 0         return $thisNode if $instance->brickName($thisNode);
673 0           $thisNode = $thisNode->{PARENT};
674             }
675 0           return;
676             }
677              
678             # Return a brick descendent, if there is one.
679             # Only singletons are followed.
680             sub brickDescendant {
681 0     0 0   my ( $instance, $node ) = @_;
682             # local $Data::Dumper::Maxdepth = 1;
683             # say STDERR join " ", __FILE__, __LINE__, Data::Dumper::Dumper($node);
684 0           my $thisNode = $node;
685 0           while ($thisNode) {
686             # say STDERR join " ", __FILE__, __LINE__, Data::Dumper::Dumper($thisNode);
687 0 0         return $thisNode if $instance->brickName($thisNode);
688 0           my $children = $thisNode->{children};
689 0 0         return if not $children;
690 0           $thisNode = $children->[0];
691             }
692 0           return;
693             }
694              
695             sub brickLC {
696 0     0 0   my ( $instance, $node ) = @_;
697 0           return $instance->nodeLC( $instance->brickNode($node) );
698             }
699              
700             # first brick node in $node's line --
701             # $node if there is no prior brick node
702             sub firstBrickOfLine {
703 0     0 0   my ( $instance, $node ) = @_;
704 0           my ($currentLine) = $instance->nodeLC($node);
705 0           my $thisNode = $node;
706 0           my $firstBrickNode;
707 0           NODE: while ($thisNode) {
708 0           my ($thisLine) = $instance->nodeLC($thisNode);
709 0 0         last NODE if $thisLine != $currentLine;
710 0 0         $firstBrickNode = $thisNode if $instance->brickName($thisNode);
711 0           $thisNode = $thisNode->{PARENT};
712             }
713 0   0       return $firstBrickNode // $node;
714             }
715              
716             # first brick node in $node's line,
717             # by inclusion list.
718             # $node if there is no prior included brick node
719             sub firstBrickOfLineInc {
720 0     0 0   my ( $instance, $node, $inclusions ) = @_;
721              
722             # say STDERR join " ", __FILE__, __LINE__, Data::Dumper::Dumper($inclusions);
723 0           my ($currentLine) = $instance->nodeLC($node);
724 0           my $thisNode = $node;
725 0           my $firstBrickNode = $node;
726 0           NODE: while ($thisNode) {
727 0           my ($thisLine) = $instance->nodeLC($thisNode);
728              
729             # say STDERR join " ", __FILE__, __LINE__, 'LC', $instance->nodeLC($thisNode);
730             # say STDERR join " ", __FILE__, __LINE__, $thisLine, $currentLine;
731 0 0         last NODE if $thisLine != $currentLine;
732             PICK_NODE: {
733 0           my $brickName = $instance->brickName($thisNode);
  0            
734              
735             # say STDERR join " ", __FILE__, __LINE__, ($brickName // '[undef]');
736 0 0         last PICK_NODE if not defined $brickName;
737 0 0         $firstBrickNode = $thisNode if $inclusions->{$brickName};
738              
739             # say STDERR join " ", __FILE__, __LINE__, $brickName;
740             }
741 0           $thisNode = $thisNode->{PARENT};
742             }
743 0           return $firstBrickNode;
744             }
745              
746             # first brick node in $node's line,
747             # with exclusions.
748             # $node if there is no prior unexcluded brick node
749             sub firstBrickOfLineExc {
750 0     0 0   my ( $instance, $node, $exclusions ) = @_;
751              
752             # say STDERR join " ", __FILE__, __LINE__, Data::Dumper::Dumper($exclusions);
753 0           my ($currentLine) = $instance->nodeLC($node);
754 0           my $thisNode = $node;
755 0           my $firstBrickNode = $node;
756 0           NODE: while ($thisNode) {
757 0           my ($thisLine) = $instance->nodeLC($thisNode);
758              
759             # say STDERR join " ", __FILE__, __LINE__, 'LC', $instance->nodeLC($thisNode);
760             # say STDERR join " ", __FILE__, __LINE__, $thisLine, $currentLine;
761 0 0         last NODE if $thisLine != $currentLine;
762             PICK_NODE: {
763 0           my $brickName = $instance->brickName($thisNode);
  0            
764              
765             # say STDERR join " ", __FILE__, __LINE__, ($brickName // '[undef]');
766 0 0         last PICK_NODE if not defined $brickName;
767              
768             # say STDERR join " ", __FILE__, __LINE__, $brickName;
769 0 0         last PICK_NODE if $exclusions->{$brickName};
770              
771             # say STDERR join " ", __FILE__, __LINE__, $brickName;
772 0           $firstBrickNode = $thisNode;
773             }
774 0           $thisNode = $thisNode->{PARENT};
775             }
776              
777             # say STDERR join " ", __FILE__, __LINE__, "returning from firstBrickOfLine";
778              
779 0           return $firstBrickNode;
780             }
781              
782             # nearest (in syntax tree) brick node in $node's line,
783             # from inclusion list
784             # $node if there is no nearest included brick node on same line
785             sub nearestBrickOfLineInc {
786 0     0 0   my ( $instance, $node, $inclusions ) = @_;
787              
788             # say STDERR join " ", __FILE__, __LINE__, Data::Dumper::Dumper($inclusions);
789 0           my ($currentLine) = $instance->nodeLC($node);
790 0           my $thisNode = $node;
791 0           NODE: while ($thisNode) {
792 0           my ($thisLine) = $instance->nodeLC($thisNode);
793              
794             # say STDERR join " ", __FILE__, __LINE__, 'LC', $instance->nodeLC($thisNode);
795             # say STDERR join " ", __FILE__, __LINE__, $thisLine, $currentLine;
796 0 0         last NODE if $thisLine != $currentLine;
797             PICK_NODE: {
798 0           my $brickName = $instance->brickName($thisNode);
  0            
799              
800             # say STDERR join " ", __FILE__, __LINE__, ($brickName // '[undef]');
801 0 0         last PICK_NODE if not defined $brickName;
802              
803             # say STDERR join " ", __FILE__, __LINE__, $brickName;
804             # say STDERR join " ", __FILE__, __LINE__, $brickName;
805 0 0         return $thisNode if $inclusions->{$brickName};
806             }
807 0           $thisNode = $thisNode->{PARENT};
808             }
809              
810             # say STDERR join " ", __FILE__, __LINE__, "returning from nearestBrickOfLineInc";
811              
812 0           return $node;
813             }
814              
815             # nearest (in syntax tree) brick node in $node's line --
816             # with exclusions.
817             # $node if there is no nearest unexcluded brick node on same line
818             sub nearestBrickOfLineExc {
819 0     0 0   my ( $instance, $node, $exclusions ) = @_;
820              
821             # say STDERR join " ", __FILE__, __LINE__, Data::Dumper::Dumper($exclusions);
822 0           my ($currentLine) = $instance->nodeLC($node);
823 0           my $thisNode = $node;
824 0           NODE: while ($thisNode) {
825 0           my ($thisLine) = $instance->nodeLC($thisNode);
826              
827             # say STDERR join " ", __FILE__, __LINE__, 'LC', $instance->nodeLC($thisNode);
828             # say STDERR join " ", __FILE__, __LINE__, $thisLine, $currentLine;
829 0 0         last NODE if $thisLine != $currentLine;
830             PICK_NODE: {
831 0           my $brickName = $instance->brickName($thisNode);
  0            
832              
833             # say STDERR join " ", __FILE__, __LINE__, ($brickName // '[undef]');
834 0 0         last PICK_NODE if not defined $brickName;
835              
836             # say STDERR join " ", __FILE__, __LINE__, $brickName;
837 0 0         last PICK_NODE if $exclusions->{$brickName};
838              
839             # say STDERR join " ", __FILE__, __LINE__, $brickName;
840 0           return $thisNode;
841             }
842 0           $thisNode = $thisNode->{PARENT};
843             }
844              
845             # say STDERR join " ", __FILE__, __LINE__, "returning from nearestBrickOfLine";
846              
847 0           return $node;
848             }
849              
850             my $semantics = <<'EOS';
851             :default ::= action=>MarpaX::Hoonlint::doNode
852             lexeme default = latm => 1 action=>[start,length,name]
853             EOS
854              
855             my $parser =
856             MarpaX::Hoonlint::YAHC->new( { semantics => $semantics, all_symbols => 1 } );
857             my $dsl = $parser->dsl();
858              
859             $MarpaX::Hoonlint::grammar = $parser->rawGrammar();
860             my %baseLintInstance = ();
861             $baseLintInstance{parser} = $parser;
862             $baseLintInstance{grammar} = $MarpaX::Hoonlint::grammar;
863              
864             my %NYI_Rule = ();
865             $NYI_Rule{$_} = 1 for qw();
866             $baseLintInstance{NYI_Rule} = \%NYI_Rule;
867              
868             my %tallRuneRule = map { +( $_, 1 ) } grep {
869             /^tall[B-Z][aeoiu][b-z][b-z][aeiou][b-z]$/
870             or /^tall[B-Z][aeoiu][b-z][b-z][aeiou][b-z]Mold$/
871             } map { $MarpaX::Hoonlint::grammar->symbol_name($_); }
872             $MarpaX::Hoonlint::grammar->symbol_ids();
873             $baseLintInstance{tallRuneRule} = \%tallRuneRule;
874              
875             # TODO: Check that these are all backdented,
876             my %tallNoteRule = map { +( $_, 1 ) } qw(
877             tallBarhep tallBardot
878             tallBuccab
879             tallCendot tallColcab
880             tallKetbar tallKethep tallKetlus tallKetsig tallKetwut
881             tallSigbar tallSigcab tallSigfas tallSiglus
882             tallTisbar tallTiscom tallTisgal
883             tallWutgal tallWutgar tallWuttis
884             tallZapgar
885             );
886             $baseLintInstance{tallNoteRule} = \%tallNoteRule;
887              
888             my %mortarLHS = map { +( $_, 1 ) }
889             qw(rick5dJog ruck5dJog rick5d ruck5d till5dSeq tall5dSeq
890             fordFile fordHoop fordHoopSeq norm5d tall5d
891             boog5d wisp5d whap5d);
892             $baseLintInstance{mortarLHS} = \%mortarLHS;
893              
894             my %tallBodyRule =
895             map { +( $_, 1 ) } grep { not $tallNoteRule{$_} } keys %tallRuneRule;
896             $baseLintInstance{tallBodyRule} = \%tallBodyRule;
897              
898             # Will include:
899             # BuccenMold BuccolMold BucwutMold
900             # Buccen Buccol Bucwut Colsig Coltar Wutbar Wutpam
901             my %tall_0RunningRule = map { +( $_, 1 ) } qw(
902             tallBuccen tallBuccenMold
903             tallBuccol tallBuccolMold
904             tallBucwut tallBucwutMold
905             tallColsig tallColtar tallTissig
906             tallWutbar tallWutpam);
907             $baseLintInstance{tall_0RunningRule} = \%tall_0RunningRule;
908              
909             my %tall_1RunningRule =
910             map { +( $_, 1 ) } qw( tallDotket tallSemcol tallSemsig tallCencolMold );
911             $baseLintInstance{tall_1RunningRule} = \%tall_1RunningRule;
912              
913             my %tall_1JoggingRule =
914             map { +( $_, 1 ) } qw(tallCentis tallCencab tallWuthep);
915             $baseLintInstance{tall_1JoggingRule} = \%tall_1JoggingRule;
916              
917             my %tall_2JoggingRule = map { +( $_, 1 ) } qw(tallCentar tallWutlus);
918             $baseLintInstance{tall_2JoggingRule} = \%tall_2JoggingRule;
919              
920             my %tallJogging1_Rule = map { +( $_, 1 ) } qw(tallTiscol);
921             $baseLintInstance{tallJogging1_Rule} = \%tallJogging1_Rule;
922              
923             my %joggingRule = map { +( $_, 1 ) } (
924             keys %tall_1JoggingRule,
925             keys %tall_2JoggingRule,
926             keys %tallJogging1_Rule
927             );
928             $baseLintInstance{joggingRule} = \%joggingRule;
929              
930             my %tallLuslusRule =
931             map { +( $_, 1 ) } qw(LuslusCell LushepCell LustisCell);
932             $baseLintInstance{tallLuslusRule} = \%tallLuslusRule;
933              
934             my %barcenAnchorExceptions = ();
935             $barcenAnchorExceptions{$_} = 1
936             for qw(tallTisgar tallTisgal LuslusCell LushepCell LustisCell);
937             $baseLintInstance{barcenAnchorExceptions} = \%barcenAnchorExceptions;
938              
939             my %tallJogRule = map { +( $_, 1 ) } qw(rick5dJog ruck5dJog);
940             $baseLintInstance{tallJogRule} = \%tallJogRule;
941              
942             my %tallBackdentRule = map { +( $_, 1 ) } qw(
943             bonz5d
944             fordFascol
945             fordFasket
946             fordFaspam
947             fordFassem
948             tallBarcol
949             tallBarsig
950             tallBartar
951             tallBartis
952             tallBuchep
953             tallBuchepMold
954             tallBucket
955             tallBucketMold
956             tallBucpat
957             tallBuctisMold
958             tallCenhep
959             tallCenhepMold
960             tallCenket
961             tallCenlus
962             tallCenlusMold
963             tallCensig
964             tallCentar
965             tallColhep
966             tallColket
967             tallCollus
968             tallDottar
969             tallDottis
970             tallKetcen
971             tallKettis
972             tallSigbuc
973             tallSigcen
974             tallSiggar
975             tallSigpam
976             tallSigwut
977             tallSigzap
978             tallTisdot
979             tallTisfas
980             tallTisgar
981             tallTishep
982             tallTisket
983             tallTislus
984             tallTissem
985             tallTistar
986             tallTiswut
987             tallWutcol
988             tallWutdot
989             tallWutket
990             tallWutpat
991             tallWutsig
992             tallZapcol
993             tallZapdot
994             tallZaptis
995             tallZapwut
996             );
997             $baseLintInstance{backdentedRule} = \%tallBackdentRule;
998              
999             $baseLintInstance{ruleDB} = [];
1000             $baseLintInstance{symbolDB} = [];
1001             $baseLintInstance{symbolReverseDB} = {};
1002              
1003             testStyleCensus(\%baseLintInstance);
1004              
1005             sub new {
1006 0     0 0   my ( $class, $config ) = (@_);
1007 0           my $fileName = $config->{fileName};
1008 0           my %lint = (%{$config}, %baseLintInstance);
  0            
1009 0           my $lintInstance = \%lint;
1010              
1011 0           bless $lintInstance, "MarpaX::Hoonlint";
1012 0           my $policies = $lintInstance->{policies};
1013 0           my $pSource = $lintInstance->{pHoonSource};
1014 0           my $parser = $lintInstance->{parser};
1015 0           $lintInstance->{topicLines} = {};
1016 0           $lintInstance->{mistakeLines} = {};
1017              
1018 0           my @data = ();
1019              
1020 0           $parser->read($pSource);
1021              
1022 0           $MarpaX::Hoonlint::recce = $parser->rawRecce();
1023 0           $lintInstance->{recce} = $MarpaX::Hoonlint::recce;
1024 0           $lintInstance->{nodeCount} = 0;
1025              
1026 0           $parser = undef; # free up memory
1027 0           my $astRef = $MarpaX::Hoonlint::recce->value($lintInstance);
1028              
1029 0           my @lineToPos = ( -1, 0 );
1030             {
1031 0           my $lastPos = 0;
  0            
1032 0           LINE: while (1) {
1033 0           my $newPos = index ${$pSource}, "\n", $lastPos;
  0            
1034              
1035             # say $newPos;
1036 0 0         last LINE if $newPos < 0;
1037 0           $lastPos = $newPos + 1;
1038 0           push @lineToPos, $lastPos;
1039             }
1040             }
1041 0           $lintInstance->{lineToPos} = \@lineToPos;
1042              
1043             # say STDERR join " ", __FILE__, __LINE__, Data::Dumper::Dumper(\@lineToPos);
1044              
1045 0 0         die "Parse failed" if not $astRef;
1046              
1047             # local $Data::Dumper::Deepcopy = 1;
1048             # local $Data::Dumper::Terse = 1;
1049             # local $Data::Dumper::Maxdepth = 3;
1050              
1051 0           my $astValue = ${$astRef};
  0            
1052              
1053 0           for my $policyShortName ( keys %{$policies} ) {
  0            
1054 0           my $policyFullName = $policies->{$policyShortName};
1055 0           my $constructor = UNIVERSAL::can( $policyFullName, 'new' );
1056 0           my $policy = $constructor->( $policyFullName, $lintInstance );
1057 0           $policy->{shortName} = $policyShortName;
1058 0           $policy->{fullName} = $policyFullName;
1059 0           $policy->{perNode} = {};
1060 0           $policy->validate($astValue);
1061             }
1062              
1063 0           print $lintInstance->contextDisplay();
1064              
1065 0           my $unusedSuppressions = $lintInstance->{unusedSuppressions};
1066 0           for my $lc ( keys %{$unusedSuppressions} ) {
  0            
1067 0           my $perLCSuppressions = $unusedSuppressions->{$lc};
1068 0           for my $policy (
1069 0           grep { $perLCSuppressions->{$_} }
1070 0           keys %{$perLCSuppressions}
1071             )
1072             {
1073 0           my $perPolicySuppressions = $perLCSuppressions->{$policy};
1074 0           for my $subpolicy (
1075 0           grep { $perPolicySuppressions->{$_} }
1076 0           keys %{$perPolicySuppressions}
1077             )
1078             {
1079 0           say "Unused suppression: $fileName $lc $policy $subpolicy";
1080             }
1081             }
1082             }
1083              
1084 0           return $lintInstance;
1085             }
1086              
1087             1;
1088              
1089             # vim: expandtab shiftwidth=4: