Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Fix block parsing #228

Merged
merged 1 commit into from
Jun 22, 2022
Merged

Fix block parsing #228

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions fortran-src.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
4 changes: 1 addition & 3 deletions src/Language/Fortran/Parser.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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')
Expand Down
52 changes: 25 additions & 27 deletions src/Language/Fortran/Parser/Fixed/Fortran77.y
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 }
Expand Down Expand Up @@ -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 }
Expand Down
1 change: 1 addition & 0 deletions test-data/f77-include/no-newline/foo.f
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1 @@
integer a
46 changes: 25 additions & 21 deletions test/Language/Fortran/Parser/Fixed/Fortran77/IncludeSpec.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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,"<unknown>") (48,9,3,"<unknown>")
st1Span = makeSrcR (24,7,2,"<unknown>") (38,21,2,"<unknown>")
expSpan = makeSrcR (32,15,2,"<unknown>") (38,21,2,"<unknown>")
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
27 changes: 15 additions & 12 deletions test/Language/Fortran/Parser/Fixed/Fortran77/ParserSpec.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down