From 78f52112524276df725f162c417ccfa6187780dd Mon Sep 17 00:00:00 2001 From: Raoul Hidalgo Charman Date: Tue, 21 Jun 2022 14:18:36 +0100 Subject: [PATCH] Fix block parsing The way it currently worked meant it would fail to parse includes that didn't end with a newline, which is valid. To allow this the block parsing had to be reorganized, with the block parser not expecting trailing newlines, but otherwise behaves the same. --- fortran-src.cabal | 1 + src/Language/Fortran/Parser.hs | 4 +- src/Language/Fortran/Parser/Fixed/Fortran77.y | 52 +++++++++---------- test-data/f77-include/no-newline/foo.f | 1 + .../Parser/Fixed/Fortran77/IncludeSpec.hs | 46 ++++++++-------- .../Parser/Fixed/Fortran77/ParserSpec.hs | 27 +++++----- 6 files changed, 68 insertions(+), 63 deletions(-) create mode 100644 test-data/f77-include/no-newline/foo.f diff --git a/fortran-src.cabal b/fortran-src.cabal index 7484ae28..c87de6c4 100644 --- a/fortran-src.cabal +++ b/fortran-src.cabal @@ -26,6 +26,7 @@ extra-source-files: README.md CHANGELOG.md test-data/f77-include/foo.f + test-data/f77-include/no-newline/foo.f test-data/rewriter/replacementsmap-columnlimit/001_foo.f test-data/rewriter/replacementsmap-columnlimit/001_foo.f.expected test-data/rewriter/replacementsmap-columnlimit/002_other.f diff --git a/src/Language/Fortran/Parser.hs b/src/Language/Fortran/Parser.hs index b5f599d3..dd1a7bfe 100644 --- a/src/Language/Fortran/Parser.hs +++ b/src/Language/Fortran/Parser.hs @@ -280,9 +280,7 @@ f77lIncludesInline dirs seen st = case st of Just blocks' -> pure $ StInclude a s e (Just blocks') Nothing -> do (fullPath, inc) <- liftIO $ readInDirs dirs path - -- Append newline to include, as grammar is defined to expect a - -- newline at the end of most blocks - case f77lIncludesInner fullPath (B.snoc inc '\n') of + case f77lIncludesInner fullPath inc of Right blocks -> do blocks' <- descendBiM (f77lIncludesInline dirs (path:seen)) blocks modify (Map.insert path blocks') diff --git a/src/Language/Fortran/Parser/Fixed/Fortran77.y b/src/Language/Fortran/Parser/Fixed/Fortran77.y index f10ba894..66a9f445 100644 --- a/src/Language/Fortran/Parser/Fixed/Fortran77.y +++ b/src/Language/Fortran/Parser/Fixed/Fortran77.y @@ -194,16 +194,16 @@ PROGRAM_UNITS :: { [ ProgramUnit A0 ] } | maybe(LABEL_IN_6COLUMN) PROGRAM_UNIT maybe(NEWLINE) { [ $2 ] } PROGRAM_UNIT :: { ProgramUnit A0 } -: program NAME NEWLINE BLOCKS ENDPROG - { PUMain () (getTransSpan $1 $5) (Just $2) (reverse $4) Nothing } -| TYPE_SPEC function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS ENDFUN - { PUFunction () (getTransSpan $1 $7) (Just $1) emptyPrefixSuffix $3 $4 Nothing (reverse $6) Nothing } -| function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS ENDFUN - { PUFunction () (getTransSpan $1 $6) Nothing emptyPrefixSuffix $2 $3 Nothing (reverse $5) Nothing } -| subroutine NAME MAYBE_ARGUMENTS NEWLINE BLOCKS ENDSUB - { PUSubroutine () (getTransSpan $1 $6) emptyPrefixSuffix $2 $3 (reverse $5) Nothing } -| blockData NEWLINE BLOCKS END { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $3) } -| blockData NAME NEWLINE BLOCKS END { PUBlockData () (getTransSpan $1 $5) (Just $2) (reverse $4) } +: program NAME BLOCKS NEWLINE ENDPROG + { PUMain () (getTransSpan $1 $5) (Just $2) (reverse $3) Nothing } +| TYPE_SPEC function NAME MAYBE_ARGUMENTS BLOCKS NEWLINE ENDFUN + { PUFunction () (getTransSpan $1 $7) (Just $1) emptyPrefixSuffix $3 $4 Nothing (reverse $5) Nothing } +| function NAME MAYBE_ARGUMENTS BLOCKS NEWLINE ENDFUN + { PUFunction () (getTransSpan $1 $6) Nothing emptyPrefixSuffix $2 $3 Nothing (reverse $4) Nothing } +| subroutine NAME MAYBE_ARGUMENTS BLOCKS NEWLINE ENDSUB + { PUSubroutine () (getTransSpan $1 $6) emptyPrefixSuffix $2 $3 (reverse $4) Nothing } +| blockData BLOCKS NEWLINE END { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $2) } +| blockData NAME BLOCKS NEWLINE END { PUBlockData () (getTransSpan $1 $5) (Just $2) (reverse $3) } | comment { let (TComment s c) = $1 in PUComment () s (Comment c) } END :: { Token } @@ -236,38 +236,36 @@ MAYBE_ID :: { Maybe Name } NAME :: { Name } : id { let (TId _ name) = $1 in name } INCLUDES :: { [ Block A0 ] } -: maybe(NEWLINE) list(BLOCK) { $2 } +: BLOCKS maybe(NEWLINE) { $1 } BLOCKS :: { [ Block A0 ] } -: BLOCKS BLOCK { $2 : $1 } +: BLOCKS NEWLINE BLOCK { $3 : $1 } +| BLOCK { [ $1 ] } | {- EMPTY -} { [ ] } BLOCK :: { Block A0 } -: IF_BLOCK NEWLINE { $1 } -| LABEL_IN_6COLUMN STATEMENT NEWLINE { BlStatement () (getTransSpan $1 $2) (Just $1) $2 } -| STATEMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 } -| COMMENT_BLOCK { $1 } +: IF_BLOCK { $1 } +| LABEL_IN_6COLUMN STATEMENT { BlStatement () (getTransSpan $1 $2) (Just $1) $2 } +| STATEMENT { BlStatement () (getSpan $1) Nothing $1 } +| comment { let (TComment s c) = $1 in BlComment () s (Comment c) } IF_BLOCK :: { Block A0 } -: if '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS +: if '(' EXPRESSION ')' then BLOCKS NEWLINE ELSE_BLOCKS { let (clauses, elseBlock, endSpan, endLabel) = $8 - in BlIf () (getTransSpan $1 endSpan) Nothing Nothing (($3, reverse $7) :| clauses) elseBlock endLabel } -| LABEL_IN_6COLUMN if '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS + in BlIf () (getTransSpan $1 endSpan) Nothing Nothing (($3, reverse $6) :| clauses) elseBlock endLabel } +| LABEL_IN_6COLUMN if '(' EXPRESSION ')' then BLOCKS NEWLINE ELSE_BLOCKS { let (clauses, elseBlock, endSpan, endLabel) = $9 - in BlIf () (getTransSpan $1 endSpan) (Just $1) Nothing (($4, reverse $8) :| clauses) elseBlock endLabel } + in BlIf () (getTransSpan $1 endSpan) (Just $1) Nothing (($4, reverse $7) :| clauses) elseBlock endLabel } ELSE_BLOCKS :: { ([(Expression A0, [Block A0])], Maybe [Block A0], SrcSpan, Maybe (Expression A0)) } -: maybe(LABEL_IN_6COLUMN) elsif '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS +: maybe(LABEL_IN_6COLUMN) elsif '(' EXPRESSION ')' then BLOCKS NEWLINE ELSE_BLOCKS { let (clauses, elseBlock, endSpan, endLabel) = $9 - in (($4, reverse $8) : clauses, elseBlock, endSpan, endLabel) } -| maybe(LABEL_IN_6COLUMN) else NEWLINE BLOCKS maybe(LABEL_IN_6COLUMN) endif - { ([], Just (reverse $4), getSpan $6, $5) } + in (($4, reverse $7) : clauses, elseBlock, endSpan, endLabel) } +| maybe(LABEL_IN_6COLUMN) else BLOCKS NEWLINE maybe(LABEL_IN_6COLUMN) endif + { ([], Just (reverse $3), getSpan $6, $5) } | maybe(LABEL_IN_6COLUMN) endif { ([], Nothing, getSpan $2, $1) } -COMMENT_BLOCK :: { Block A0 } -: comment NEWLINE { let (TComment s c) = $1 in BlComment () s (Comment c) } - NEWLINE :: { Token } : NEWLINE newline { $1 } | newline { $1 } diff --git a/test-data/f77-include/no-newline/foo.f b/test-data/f77-include/no-newline/foo.f new file mode 100644 index 00000000..130be44b --- /dev/null +++ b/test-data/f77-include/no-newline/foo.f @@ -0,0 +1 @@ + integer a \ No newline at end of file diff --git a/test/Language/Fortran/Parser/Fixed/Fortran77/IncludeSpec.hs b/test/Language/Fortran/Parser/Fixed/Fortran77/IncludeSpec.hs index 804d1883..ab8799fb 100644 --- a/test/Language/Fortran/Parser/Fixed/Fortran77/IncludeSpec.hs +++ b/test/Language/Fortran/Parser/Fixed/Fortran77/IncludeSpec.hs @@ -22,31 +22,35 @@ spec = " include 'foo.f'", " end" ] - inc = "./test-data/f77-include" name = "bar" - pf = ProgramFile mi77' [pu] puSpan = makeSrcR (6,7,1,"") (48,9,3,"") st1Span = makeSrcR (24,7,2,"") (38,21,2,"") expSpan = makeSrcR (32,15,2,"") (38,21,2,"") + pf inc = ProgramFile mi77' [pu] + where + -- the expansion returns the span in the included file + -- it should return the span at the inclusion + foo = inc "foo.f" + st2Span = makeSrcR (6,7,1, foo) (14,15,1,foo) + declSpan = makeSrcR (6,7,1,foo) (14,15,1,foo) + typeSpan = makeSrcR (6,7,1,foo) (12,13,1,foo) + blockSpan = makeSrcR (14,15,1,foo) (14,15,1,foo) + varGen' str = ExpValue () blockSpan $ ValVariable str - -- the expansion returns the span in the included file - -- it should return the span at the inclusion - foo = inc "foo.f" - st2Span = makeSrcR (6,7,1, foo) (14,15,1,foo) - declSpan = makeSrcR (6,7,1,foo) (14,15,1,foo) - typeSpan = makeSrcR (6,7,1,foo) (12,13,1,foo) - blockSpan = makeSrcR (14,15,1,foo) (14,15,1,foo) - varGen' str = ExpValue () blockSpan $ ValVariable str - - pu = PUMain () puSpan (Just name) blocks Nothing - blocks = [bl1] - decl = Declarator () blockSpan (varGen' "a") ScalarDecl Nothing Nothing - typeSpec = TypeSpec () typeSpan TypeInteger Nothing - st2 = StDeclaration () st2Span typeSpec Nothing (AList () blockSpan [decl]) - bl1 = BlStatement () st1Span Nothing st1 - st1 = StInclude () st1Span ex (Just [bl2]) - ex = ExpValue () expSpan (ValString "foo.f") - bl2 = BlStatement () declSpan Nothing st2 + pu = PUMain () puSpan (Just name) blocks Nothing + blocks = [bl1] + decl = Declarator () blockSpan (varGen' "a") ScalarDecl Nothing Nothing + typeSpec = TypeSpec () typeSpan TypeInteger Nothing + st2 = StDeclaration () st2Span typeSpec Nothing (AList () blockSpan [decl]) + bl1 = BlStatement () st1Span Nothing st1 + st1 = StInclude () st1Span ex (Just [bl2]) + ex = ExpValue () expSpan (ValString "foo.f") + bl2 = BlStatement () declSpan Nothing st2 it "includes some files and expands them" $ do + let inc = "." "test-data" "f77-include" + pfParsed <- iParser [inc] source + pfParsed `shouldBe` pf inc + it "includes without a newline behave the same" $ do + let inc = "." "test-data" "f77-include" "no-newline" pfParsed <- iParser [inc] source - pfParsed `shouldBe` pf + pfParsed `shouldBe` pf inc diff --git a/test/Language/Fortran/Parser/Fixed/Fortran77/ParserSpec.hs b/test/Language/Fortran/Parser/Fixed/Fortran77/ParserSpec.hs index a698402d..1284bd54 100644 --- a/test/Language/Fortran/Parser/Fixed/Fortran77/ParserSpec.hs +++ b/test/Language/Fortran/Parser/Fixed/Fortran77/ParserSpec.hs @@ -11,6 +11,7 @@ import qualified Language.Fortran.Parser.Fixed.Fortran77 as F77 import qualified Language.Fortran.Parser.Fixed.Lexer as Fixed import Prelude hiding ( exp ) +import Data.List ( intercalate ) import qualified Data.ByteString.Char8 as B parseWith :: FortranVersion -> Parse Fixed.AlexInput Fixed.Token a -> String -> a @@ -217,23 +218,25 @@ spec = it "unlabelled" $ do let bl = BlIf () u Nothing Nothing ((valTrue, inner) :| []) (Just inner) Nothing - src = unlines [ " if (.true.) then ! comment if" - , " print *, 'foo'" - , " else ! comment else" - , " print *, 'foo'" - , " endif ! comment end" - ] + src = intercalate "\n" + [ " if (.true.) then ! comment if" + , " print *, 'foo'" + , " else ! comment else" + , " print *, 'foo'" + , " endif ! comment end" + ] bParser src `shouldBe'` bl it "labelled" $ do let label = Just . intGen bl = BlIf () u (label 10) Nothing ((valTrue, inner) :| []) (Just inner) (label 30) - src = unlines [ "10 if (.true.) then ! comment if" - , " print *, 'foo'" - , "20 else ! comment else" - , " print *, 'foo'" - , "30 endif ! comment end" - ] + src = intercalate "\n" + [ "10 if (.true.) then ! comment if" + , " print *, 'foo'" + , "20 else ! comment else" + , " print *, 'foo'" + , "30 endif ! comment end" + ] bParser src `shouldBe'` bl describe "Legacy Extensions" $ do