Skip to content

Commit 3ad155a

Browse files
raehikraehik
committed
fix special CASE block comment parse fail (all)
1 parent 401fd71 commit 3ad155a

File tree

5 files changed

+75
-57
lines changed

5 files changed

+75
-57
lines changed

‎src/Language/Fortran/Parser/Fortran2003.y‎

Lines changed: 42 additions & 34 deletions
Original file line numberDiff line numberDiff line change
@@ -356,8 +356,8 @@ IMPORT_NAME_LIST :: { [Expression A0] }
356356
BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] }
357357

358358
BLOCK :: { Block A0 }
359-
: IF_BLOCK NEWLINE { $1 }
360-
| CASE_BLOCK NEWLINE { $1 }
359+
: IF_BLOCK MAYBE_COMMENT NEWLINE { $1 }
360+
| CASE_BLOCK MAYBE_COMMENT NEWLINE { $1 }
361361
| INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE
362362
{ BlStatement () (getTransSpan $1 $2) (Just $1) $2 }
363363
| STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 }
@@ -369,38 +369,38 @@ BLOCK :: { Block A0 }
369369

370370
IF_BLOCK :: { Block A0 }
371371
IF_BLOCK
372-
: if '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS
372+
: if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
373373
{ let { startSpan = getSpan $1;
374-
(endSpan, conds, blocks, endLabel) = $8;
374+
(endSpan, conds, blocks, endLabel) = $9;
375375
span = getTransSpan startSpan endSpan }
376-
in BlIf () span Nothing Nothing ((Just $3):conds) ((reverse $7):blocks) endLabel }
377-
| id ':' if '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS
376+
in BlIf () span Nothing Nothing ((Just $3):conds) ((reverse $8):blocks) endLabel }
377+
| id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
378378
{ let { TId startSpan startName = $1;
379-
(endSpan, conds, blocks, endLabel) = $10;
379+
(endSpan, conds, blocks, endLabel) = $11;
380380
span = getTransSpan startSpan endSpan }
381-
in BlIf () span Nothing (Just startName) ((Just $5):conds) ((reverse $9):blocks) endLabel }
382-
| INTEGER_LITERAL if '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS
381+
in BlIf () span Nothing (Just startName) ((Just $5):conds) ((reverse $10):blocks) endLabel }
382+
| INTEGER_LITERAL if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
383383
{ let { startSpan = getSpan $1;
384384
startLabel = Just $1;
385-
(endSpan, conds, blocks, endLabel) = $9;
385+
(endSpan, conds, blocks, endLabel) = $10;
386386
span = getTransSpan startSpan endSpan }
387-
in BlIf () span startLabel Nothing ((Just $4):conds) ((reverse $8):blocks) endLabel }
388-
| INTEGER_LITERAL id ':' if '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS
387+
in BlIf () span startLabel Nothing ((Just $4):conds) ((reverse $9):blocks) endLabel }
388+
| INTEGER_LITERAL id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
389389
{ let { startSpan = getSpan $1;
390390
startLabel = Just $1;
391391
TId _ startName = $2;
392-
(endSpan, conds, blocks, endLabel) = $11;
392+
(endSpan, conds, blocks, endLabel) = $12;
393393
span = getTransSpan startSpan endSpan }
394-
in BlIf () span startLabel (Just startName) ((Just $6):conds) ((reverse $10):blocks) endLabel }
394+
in BlIf () span startLabel (Just startName) ((Just $6):conds) ((reverse $11):blocks) endLabel }
395395

396396
ELSE_BLOCKS :: { (SrcSpan, [Maybe (Expression A0)], [[Block A0]], Maybe (Expression A0)) }
397397
ELSE_BLOCKS
398-
: maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS
399-
{ let (endSpan, conds, blocks, endLabel) = $9
400-
in (endSpan, Just $4 : conds, reverse $8 : blocks, endLabel) }
401-
| maybe(INTEGER_LITERAL) else NEWLINE BLOCKS END_IF
402-
{ let (endSpan, endLabel) = $5
403-
in (endSpan, [Nothing], [reverse $4], endLabel) }
398+
: maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
399+
{ let (endSpan, conds, blocks, endLabel) = $10
400+
in (endSpan, Just $4 : conds, reverse $9 : blocks, endLabel) }
401+
| maybe(INTEGER_LITERAL) else MAYBE_COMMENT NEWLINE BLOCKS END_IF
402+
{ let (endSpan, endLabel) = $6
403+
in (endSpan, [Nothing], [reverse $5], endLabel) }
404404
| END_IF { let (endSpan, endLabel) = $1 in (endSpan, [], [], endLabel) }
405405

406406
END_IF :: { (SrcSpan, Maybe (Expression A0)) }
@@ -412,32 +412,40 @@ END_IF
412412

413413
CASE_BLOCK :: { Block A0 }
414414
CASE_BLOCK
415-
: selectcase '(' EXPRESSION ')' NEWLINE CASES
416-
{ let { (caseRanges, blocks, endLabel, endSpan) = $6;
415+
: selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
416+
{ let { (caseRanges, blocks, endLabel, endSpan) = $7;
417417
span = getTransSpan $1 endSpan }
418418
in BlCase () span Nothing Nothing $3 caseRanges blocks endLabel }
419-
| INTEGER_LITERAL selectcase '(' EXPRESSION ')' NEWLINE CASES
420-
{ let { (caseRanges, blocks, endLabel, endSpan) = $7;
419+
| INTEGER_LITERAL selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
420+
{ let { (caseRanges, blocks, endLabel, endSpan) = $8;
421421
span = getTransSpan $1 endSpan }
422422
in BlCase () span (Just $1) Nothing $4 caseRanges blocks endLabel }
423-
| id ':' selectcase '(' EXPRESSION ')' NEWLINE CASES
424-
{ let { (caseRanges, blocks, endLabel, endSpan) = $8;
423+
| id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
424+
{ let { (caseRanges, blocks, endLabel, endSpan) = $9;
425425
TId s startName = $1;
426426
span = getTransSpan s endSpan }
427427
in BlCase () span Nothing (Just startName) $5 caseRanges blocks endLabel }
428-
| INTEGER_LITERAL id ':' selectcase '(' EXPRESSION ')' NEWLINE CASES
429-
{ let { (caseRanges, blocks, endLabel, endSpan) = $9;
428+
| INTEGER_LITERAL id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
429+
{ let { (caseRanges, blocks, endLabel, endSpan) = $10;
430430
TId s startName = $2;
431431
span = getTransSpan s endSpan }
432432
in BlCase () span (Just $1) (Just startName) $6 caseRanges blocks endLabel }
433433

434+
-- We store line comments as statements, but this raises an issue: we have
435+
-- nowhere to place comments after a SELECT CASE but before a CASE. So we drop
436+
-- them. The inner CASES_ rule does /not/ use this, because comments can always
437+
-- be parsed as belonging to to the above CASE block.
434438
CASES :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }
435-
: maybe(INTEGER_LITERAL) case '(' INDICIES ')' NEWLINE BLOCKS CASES
436-
{ let (scrutinees, blocks, endLabel, endSpan) = $8
437-
in (Just (fromReverseList $4) : scrutinees, reverse $7 : blocks, endLabel, endSpan) }
438-
| maybe(INTEGER_LITERAL) case default NEWLINE BLOCKS END_SELECT
439-
{ let (endLabel, endSpan) = $6
440-
in ([Nothing], [$5], endLabel, endSpan) }
439+
: COMMENT_BLOCK CASES_ { $2 }
440+
| CASES_ { $1 }
441+
442+
CASES_ :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }
443+
: maybe(INTEGER_LITERAL) case '(' INDICIES ')' MAYBE_COMMENT NEWLINE BLOCKS CASES_
444+
{ let (scrutinees, blocks, endLabel, endSpan) = $9
445+
in (Just (fromReverseList $4) : scrutinees, reverse $8 : blocks, endLabel, endSpan) }
446+
| maybe(INTEGER_LITERAL) case default MAYBE_COMMENT NEWLINE BLOCKS END_SELECT
447+
{ let (endLabel, endSpan) = $7
448+
in ([Nothing], [$6], endLabel, endSpan) }
441449
| END_SELECT
442450
{ let (endLabel, endSpan) = $1
443451
in ([], [], endLabel, endSpan) }

‎src/Language/Fortran/Parser/Fortran90.y‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -318,17 +318,17 @@ BLOCK :: { Block A0 }
318318

319319
IF_BLOCK :: { Block A0 }
320320
IF_BLOCK
321-
: if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
321+
: if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
322322
{ let { startSpan = getSpan $1;
323323
(endSpan, conds, blocks, endLabel) = $9;
324324
span = getTransSpan startSpan endSpan }
325325
in BlIf () span Nothing Nothing ((Just $3):conds) ((reverse $8):blocks) endLabel }
326-
| id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
326+
| id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
327327
{ let { TId startSpan startName = $1;
328328
(endSpan, conds, blocks, endLabel) = $11;
329329
span = getTransSpan startSpan endSpan }
330330
in BlIf () span Nothing (Just startName) ((Just $5):conds) ((reverse $10):blocks) endLabel }
331-
| INTEGER_LITERAL if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
331+
| INTEGER_LITERAL if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
332332
{ let { startSpan = getSpan $1;
333333
startLabel = Just $1;
334334
(endSpan, conds, blocks, endLabel) = $10;
@@ -347,7 +347,7 @@ ELSE_BLOCKS
347347
: maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
348348
{ let (endSpan, conds, blocks, endLabel) = $10
349349
in (endSpan, Just $4 : conds, reverse $9 : blocks, endLabel) }
350-
| maybe(INTEGER_LITERAL) else MAYBE_COMMENT NEWLINE BLOCKS END_IF
350+
| maybe(INTEGER_LITERAL) else MAYBE_COMMENT NEWLINE BLOCKS END_IF
351351
{ let (endSpan, endLabel) = $6
352352
in (endSpan, [Nothing], [reverse $5], endLabel) }
353353
| END_IF { let (endSpan, endLabel) = $1 in (endSpan, [], [], endLabel) }
@@ -391,7 +391,7 @@ CASES_ :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcS
391391
: maybe(INTEGER_LITERAL) case '(' INDICIES ')' MAYBE_COMMENT NEWLINE BLOCKS CASES_
392392
{ let (scrutinees, blocks, endLabel, endSpan) = $9
393393
in (Just (fromReverseList $4) : scrutinees, reverse $8 : blocks, endLabel, endSpan) }
394-
| maybe(INTEGER_LITERAL) case default MAYBE_COMMENT NEWLINE BLOCKS END_SELECT
394+
| maybe(INTEGER_LITERAL) case default MAYBE_COMMENT NEWLINE BLOCKS END_SELECT
395395
{ let (endLabel, endSpan) = $7
396396
in ([Nothing], [$6], endLabel, endSpan) }
397397
| END_SELECT

‎src/Language/Fortran/Parser/Fortran95.y‎

Lines changed: 17 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -329,17 +329,17 @@ BLOCK :: { Block A0 }
329329

330330
IF_BLOCK :: { Block A0 }
331331
IF_BLOCK
332-
: if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
332+
: if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
333333
{ let { startSpan = getSpan $1;
334334
(endSpan, conds, blocks, endLabel) = $9;
335335
span = getTransSpan startSpan endSpan }
336336
in BlIf () span Nothing Nothing ((Just $3):conds) ((reverse $8):blocks) endLabel }
337-
| id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
337+
| id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
338338
{ let { TId startSpan startName = $1;
339339
(endSpan, conds, blocks, endLabel) = $11;
340340
span = getTransSpan startSpan endSpan }
341341
in BlIf () span Nothing (Just startName) ((Just $5):conds) ((reverse $10):blocks) endLabel }
342-
| INTEGER_LITERAL if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
342+
| INTEGER_LITERAL if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
343343
{ let { startSpan = getSpan $1;
344344
startLabel = Just $1;
345345
(endSpan, conds, blocks, endLabel) = $10;
@@ -358,7 +358,7 @@ ELSE_BLOCKS
358358
: maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
359359
{ let (endSpan, conds, blocks, endLabel) = $10
360360
in (endSpan, Just $4 : conds, reverse $9 : blocks, endLabel) }
361-
| maybe(INTEGER_LITERAL) else MAYBE_COMMENT NEWLINE BLOCKS END_IF
361+
| maybe(INTEGER_LITERAL) else MAYBE_COMMENT NEWLINE BLOCKS END_IF
362362
{ let (endSpan, endLabel) = $6
363363
in (endSpan, [Nothing], [reverse $5], endLabel) }
364364
| END_IF { let (endSpan, endLabel) = $1 in (endSpan, [], [], endLabel) }
@@ -372,15 +372,15 @@ END_IF
372372

373373
CASE_BLOCK :: { Block A0 }
374374
CASE_BLOCK
375-
: selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
375+
: selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
376376
{ let { (caseRanges, blocks, endLabel, endSpan) = $7;
377377
span = getTransSpan $1 endSpan }
378378
in BlCase () span Nothing Nothing $3 caseRanges blocks endLabel }
379-
| INTEGER_LITERAL selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
379+
| INTEGER_LITERAL selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
380380
{ let { (caseRanges, blocks, endLabel, endSpan) = $8;
381381
span = getTransSpan $1 endSpan }
382382
in BlCase () span (Just $1) Nothing $4 caseRanges blocks endLabel }
383-
| id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
383+
| id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
384384
{ let { (caseRanges, blocks, endLabel, endSpan) = $9;
385385
TId s startName = $1;
386386
span = getTransSpan s endSpan }
@@ -391,11 +391,19 @@ CASE_BLOCK
391391
span = getTransSpan s endSpan }
392392
in BlCase () span (Just $1) (Just startName) $6 caseRanges blocks endLabel }
393393

394+
-- We store line comments as statements, but this raises an issue: we have
395+
-- nowhere to place comments after a SELECT CASE but before a CASE. So we drop
396+
-- them. The inner CASES_ rule does /not/ use this, because comments can always
397+
-- be parsed as belonging to to the above CASE block.
394398
CASES :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }
395-
: maybe(INTEGER_LITERAL) case '(' INDICIES ')' MAYBE_COMMENT NEWLINE BLOCKS CASES
399+
: COMMENT_BLOCK CASES_ { $2 }
400+
| CASES_ { $1 }
401+
402+
CASES_ :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }
403+
: maybe(INTEGER_LITERAL) case '(' INDICIES ')' MAYBE_COMMENT NEWLINE BLOCKS CASES_
396404
{ let (scrutinees, blocks, endLabel, endSpan) = $9
397405
in (Just (fromReverseList $4) : scrutinees, reverse $8 : blocks, endLabel, endSpan) }
398-
| maybe(INTEGER_LITERAL) case default MAYBE_COMMENT NEWLINE BLOCKS END_SELECT
406+
| maybe(INTEGER_LITERAL) case default MAYBE_COMMENT NEWLINE BLOCKS END_SELECT
399407
{ let (endLabel, endSpan) = $7
400408
in ([Nothing], [$6], endLabel, endSpan) }
401409
| END_SELECT

‎test/Language/Fortran/Parser/Fortran90Spec.hs‎

Lines changed: 10 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -476,27 +476,28 @@ spec =
476476
ind3Plus = AList () u . pure $ IxRange () u (Just $ intLit "3") Nothing Nothing
477477
conds = [Just ind2, Just ind3Plus, Nothing]
478478
it "unlabelled case block (with inline comments to be stripped)" $ do
479-
let src = unlines [ "select case (x) ! comment select"
480-
, "case (2) ! comment case 1"
479+
let src = unlines [ "select case (x) ! inline select"
480+
, "! full line before first case (unrepresentable)"
481+
, "case (2) ! inline case 1"
481482
, "print *, 'foo'"
482-
, "case (3:) ! comment case 2"
483+
, "case (3:) ! inline case 2"
483484
, "print *, 'bar'"
484-
, "case default ! comment case 3"
485+
, "case default ! inline case 3"
485486
, "print *, 'baz'"
486-
, "end select ! comment end"
487+
, "end select ! inline end"
487488
]
488489
blocks = (fmap . fmap) printBlock [["foo"], ["bar"], ["baz"]]
489490
block = BlCase () u Nothing Nothing (varGen "x") conds blocks Nothing
490491
blParser src `shouldBe'` block
491492
it "labelled case block (with inline comments to be stripped" $ do
492493
let src = unlines [ "10 mylabel: select case (x) ! comment select"
493-
, "20 case (2) ! comment case 1"
494+
, "20 case (2) ! inline case 1"
494495
, "30 print *, 'foo'"
495-
, "40 case (3:) ! comment case 2"
496+
, "40 case (3:) ! inline case 2"
496497
, "50 print *, 'bar'"
497-
, "60 case default ! comment case 3"
498+
, "60 case default ! inline case 3"
498499
, "70 print *, 'baz'"
499-
, "80 end select mylabel ! comment end"
500+
, "80 end select mylabel ! inline end"
500501
]
501502
blocks = (fmap . fmap)
502503
(\(label, arg) -> BlStatement () u (Just $ intLit label) $ printStmt arg)

‎test/Language/Fortran/Parser/Fortran95Spec.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -526,6 +526,7 @@ spec =
526526
conds = [Just ind2, Just ind3Plus, Nothing]
527527
it "unlabelled case block (with inline comments to be stripped)" $ do
528528
let src = unlines [ "select case (x) ! comment select"
529+
, "! full line before first case (unrepresentable)"
529530
, "case (2) ! comment case 1"
530531
, "print *, 'foo'"
531532
, "case (3:) ! comment case 2"

0 commit comments

Comments
 (0)