Skip to content

Commit e6f750f

Browse files
RaoulHCraehik
RaoulHC
authored and
raehik
committed
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.
1 parent 44a7002 commit e6f750f

File tree

6 files changed

+68
-63
lines changed

6 files changed

+68
-63
lines changed

‎fortran-src.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,7 @@ extra-source-files:
2626
README.md
2727
CHANGELOG.md
2828
test-data/f77-include/foo.f
29+
test-data/f77-include/no-newline/foo.f
2930
test-data/rewriter/replacementsmap-columnlimit/001_foo.f
3031
test-data/rewriter/replacementsmap-columnlimit/001_foo.f.expected
3132
test-data/rewriter/replacementsmap-columnlimit/002_other.f

‎src/Language/Fortran/Parser.hs

Lines changed: 1 addition & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -280,9 +280,7 @@ f77lIncludesInline dirs seen st = case st of
280280
Just blocks' -> pure $ StInclude a s e (Just blocks')
281281
Nothing -> do
282282
(fullPath, inc) <- liftIO $ readInDirs dirs path
283-
-- Append newline to include, as grammar is defined to expect a
284-
-- newline at the end of most blocks
285-
case f77lIncludesInner fullPath (B.snoc inc '\n') of
283+
case f77lIncludesInner fullPath inc of
286284
Right blocks -> do
287285
blocks' <- descendBiM (f77lIncludesInline dirs (path:seen)) blocks
288286
modify (Map.insert path blocks')

‎src/Language/Fortran/Parser/Fixed/Fortran77.y

Lines changed: 25 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -194,16 +194,16 @@ PROGRAM_UNITS :: { [ ProgramUnit A0 ] }
194194
| maybe(LABEL_IN_6COLUMN) PROGRAM_UNIT maybe(NEWLINE) { [ $2 ] }
195195

196196
PROGRAM_UNIT :: { ProgramUnit A0 }
197-
: program NAME NEWLINE BLOCKS ENDPROG
198-
{ PUMain () (getTransSpan $1 $5) (Just $2) (reverse $4) Nothing }
199-
| TYPE_SPEC function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS ENDFUN
200-
{ PUFunction () (getTransSpan $1 $7) (Just $1) emptyPrefixSuffix $3 $4 Nothing (reverse $6) Nothing }
201-
| function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS ENDFUN
202-
{ PUFunction () (getTransSpan $1 $6) Nothing emptyPrefixSuffix $2 $3 Nothing (reverse $5) Nothing }
203-
| subroutine NAME MAYBE_ARGUMENTS NEWLINE BLOCKS ENDSUB
204-
{ PUSubroutine () (getTransSpan $1 $6) emptyPrefixSuffix $2 $3 (reverse $5) Nothing }
205-
| blockData NEWLINE BLOCKS END { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $3) }
206-
| blockData NAME NEWLINE BLOCKS END { PUBlockData () (getTransSpan $1 $5) (Just $2) (reverse $4) }
197+
: program NAME BLOCKS NEWLINE ENDPROG
198+
{ PUMain () (getTransSpan $1 $5) (Just $2) (reverse $3) Nothing }
199+
| TYPE_SPEC function NAME MAYBE_ARGUMENTS BLOCKS NEWLINE ENDFUN
200+
{ PUFunction () (getTransSpan $1 $7) (Just $1) emptyPrefixSuffix $3 $4 Nothing (reverse $5) Nothing }
201+
| function NAME MAYBE_ARGUMENTS BLOCKS NEWLINE ENDFUN
202+
{ PUFunction () (getTransSpan $1 $6) Nothing emptyPrefixSuffix $2 $3 Nothing (reverse $4) Nothing }
203+
| subroutine NAME MAYBE_ARGUMENTS BLOCKS NEWLINE ENDSUB
204+
{ PUSubroutine () (getTransSpan $1 $6) emptyPrefixSuffix $2 $3 (reverse $4) Nothing }
205+
| blockData BLOCKS NEWLINE END { PUBlockData () (getTransSpan $1 $4) Nothing (reverse $2) }
206+
| blockData NAME BLOCKS NEWLINE END { PUBlockData () (getTransSpan $1 $5) (Just $2) (reverse $3) }
207207
| comment { let (TComment s c) = $1 in PUComment () s (Comment c) }
208208

209209
END :: { Token }
@@ -236,38 +236,36 @@ MAYBE_ID :: { Maybe Name }
236236
NAME :: { Name } : id { let (TId _ name) = $1 in name }
237237

238238
INCLUDES :: { [ Block A0 ] }
239-
: maybe(NEWLINE) list(BLOCK) { $2 }
239+
: BLOCKS maybe(NEWLINE) { $1 }
240240

241241
BLOCKS :: { [ Block A0 ] }
242-
: BLOCKS BLOCK { $2 : $1 }
242+
: BLOCKS NEWLINE BLOCK { $3 : $1 }
243+
| BLOCK { [ $1 ] }
243244
| {- EMPTY -} { [ ] }
244245

245246
BLOCK :: { Block A0 }
246-
: IF_BLOCK NEWLINE { $1 }
247-
| LABEL_IN_6COLUMN STATEMENT NEWLINE { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }
248-
| STATEMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 }
249-
| COMMENT_BLOCK { $1 }
247+
: IF_BLOCK { $1 }
248+
| LABEL_IN_6COLUMN STATEMENT { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }
249+
| STATEMENT { BlStatement () (getSpan $1) Nothing $1 }
250+
| comment { let (TComment s c) = $1 in BlComment () s (Comment c) }
250251

251252
IF_BLOCK :: { Block A0 }
252-
: if '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS
253+
: if '(' EXPRESSION ')' then BLOCKS NEWLINE ELSE_BLOCKS
253254
{ let (clauses, elseBlock, endSpan, endLabel) = $8
254-
in BlIf () (getTransSpan $1 endSpan) Nothing Nothing (($3, reverse $7) :| clauses) elseBlock endLabel }
255-
| LABEL_IN_6COLUMN if '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS
255+
in BlIf () (getTransSpan $1 endSpan) Nothing Nothing (($3, reverse $6) :| clauses) elseBlock endLabel }
256+
| LABEL_IN_6COLUMN if '(' EXPRESSION ')' then BLOCKS NEWLINE ELSE_BLOCKS
256257
{ let (clauses, elseBlock, endSpan, endLabel) = $9
257-
in BlIf () (getTransSpan $1 endSpan) (Just $1) Nothing (($4, reverse $8) :| clauses) elseBlock endLabel }
258+
in BlIf () (getTransSpan $1 endSpan) (Just $1) Nothing (($4, reverse $7) :| clauses) elseBlock endLabel }
258259

259260
ELSE_BLOCKS :: { ([(Expression A0, [Block A0])], Maybe [Block A0], SrcSpan, Maybe (Expression A0)) }
260-
: maybe(LABEL_IN_6COLUMN) elsif '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS
261+
: maybe(LABEL_IN_6COLUMN) elsif '(' EXPRESSION ')' then BLOCKS NEWLINE ELSE_BLOCKS
261262
{ let (clauses, elseBlock, endSpan, endLabel) = $9
262-
in (($4, reverse $8) : clauses, elseBlock, endSpan, endLabel) }
263-
| maybe(LABEL_IN_6COLUMN) else NEWLINE BLOCKS maybe(LABEL_IN_6COLUMN) endif
264-
{ ([], Just (reverse $4), getSpan $6, $5) }
263+
in (($4, reverse $7) : clauses, elseBlock, endSpan, endLabel) }
264+
| maybe(LABEL_IN_6COLUMN) else BLOCKS NEWLINE maybe(LABEL_IN_6COLUMN) endif
265+
{ ([], Just (reverse $3), getSpan $6, $5) }
265266
| maybe(LABEL_IN_6COLUMN) endif
266267
{ ([], Nothing, getSpan $2, $1) }
267268

268-
COMMENT_BLOCK :: { Block A0 }
269-
: comment NEWLINE { let (TComment s c) = $1 in BlComment () s (Comment c) }
270-
271269
NEWLINE :: { Token }
272270
: NEWLINE newline { $1 }
273271
| newline { $1 }

‎test-data/f77-include/no-newline/foo.f

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
integer a

‎test/Language/Fortran/Parser/Fixed/Fortran77/IncludeSpec.hs

Lines changed: 25 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -22,31 +22,35 @@ spec =
2222
" include 'foo.f'",
2323
" end"
2424
]
25-
inc = "./test-data/f77-include"
2625
name = "bar"
27-
pf = ProgramFile mi77' [pu]
2826
puSpan = makeSrcR (6,7,1,"<unknown>") (48,9,3,"<unknown>")
2927
st1Span = makeSrcR (24,7,2,"<unknown>") (38,21,2,"<unknown>")
3028
expSpan = makeSrcR (32,15,2,"<unknown>") (38,21,2,"<unknown>")
29+
pf inc = ProgramFile mi77' [pu]
30+
where
31+
-- the expansion returns the span in the included file
32+
-- it should return the span at the inclusion
33+
foo = inc </> "foo.f"
34+
st2Span = makeSrcR (6,7,1, foo) (14,15,1,foo)
35+
declSpan = makeSrcR (6,7,1,foo) (14,15,1,foo)
36+
typeSpan = makeSrcR (6,7,1,foo) (12,13,1,foo)
37+
blockSpan = makeSrcR (14,15,1,foo) (14,15,1,foo)
38+
varGen' str = ExpValue () blockSpan $ ValVariable str
3139

32-
-- the expansion returns the span in the included file
33-
-- it should return the span at the inclusion
34-
foo = inc </> "foo.f"
35-
st2Span = makeSrcR (6,7,1, foo) (14,15,1,foo)
36-
declSpan = makeSrcR (6,7,1,foo) (14,15,1,foo)
37-
typeSpan = makeSrcR (6,7,1,foo) (12,13,1,foo)
38-
blockSpan = makeSrcR (14,15,1,foo) (14,15,1,foo)
39-
varGen' str = ExpValue () blockSpan $ ValVariable str
40-
41-
pu = PUMain () puSpan (Just name) blocks Nothing
42-
blocks = [bl1]
43-
decl = Declarator () blockSpan (varGen' "a") ScalarDecl Nothing Nothing
44-
typeSpec = TypeSpec () typeSpan TypeInteger Nothing
45-
st2 = StDeclaration () st2Span typeSpec Nothing (AList () blockSpan [decl])
46-
bl1 = BlStatement () st1Span Nothing st1
47-
st1 = StInclude () st1Span ex (Just [bl2])
48-
ex = ExpValue () expSpan (ValString "foo.f")
49-
bl2 = BlStatement () declSpan Nothing st2
40+
pu = PUMain () puSpan (Just name) blocks Nothing
41+
blocks = [bl1]
42+
decl = Declarator () blockSpan (varGen' "a") ScalarDecl Nothing Nothing
43+
typeSpec = TypeSpec () typeSpan TypeInteger Nothing
44+
st2 = StDeclaration () st2Span typeSpec Nothing (AList () blockSpan [decl])
45+
bl1 = BlStatement () st1Span Nothing st1
46+
st1 = StInclude () st1Span ex (Just [bl2])
47+
ex = ExpValue () expSpan (ValString "foo.f")
48+
bl2 = BlStatement () declSpan Nothing st2
5049
it "includes some files and expands them" $ do
50+
let inc = "." </> "test-data" </> "f77-include"
51+
pfParsed <- iParser [inc] source
52+
pfParsed `shouldBe` pf inc
53+
it "includes without a newline behave the same" $ do
54+
let inc = "." </> "test-data" </> "f77-include" </> "no-newline"
5155
pfParsed <- iParser [inc] source
52-
pfParsed `shouldBe` pf
56+
pfParsed `shouldBe` pf inc

‎test/Language/Fortran/Parser/Fixed/Fortran77/ParserSpec.hs

Lines changed: 15 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ import qualified Language.Fortran.Parser.Fixed.Fortran77 as F77
1111
import qualified Language.Fortran.Parser.Fixed.Lexer as Fixed
1212

1313
import Prelude hiding ( exp )
14+
import Data.List ( intercalate )
1415
import qualified Data.ByteString.Char8 as B
1516

1617
parseWith :: FortranVersion -> Parse Fixed.AlexInput Fixed.Token a -> String -> a
@@ -217,23 +218,25 @@ spec =
217218

218219
it "unlabelled" $ do
219220
let bl = BlIf () u Nothing Nothing ((valTrue, inner) :| []) (Just inner) Nothing
220-
src = unlines [ " if (.true.) then ! comment if"
221-
, " print *, 'foo'"
222-
, " else ! comment else"
223-
, " print *, 'foo'"
224-
, " endif ! comment end"
225-
]
221+
src = intercalate "\n"
222+
[ " if (.true.) then ! comment if"
223+
, " print *, 'foo'"
224+
, " else ! comment else"
225+
, " print *, 'foo'"
226+
, " endif ! comment end"
227+
]
226228
bParser src `shouldBe'` bl
227229

228230
it "labelled" $ do
229231
let label = Just . intGen
230232
bl = BlIf () u (label 10) Nothing ((valTrue, inner) :| []) (Just inner) (label 30)
231-
src = unlines [ "10 if (.true.) then ! comment if"
232-
, " print *, 'foo'"
233-
, "20 else ! comment else"
234-
, " print *, 'foo'"
235-
, "30 endif ! comment end"
236-
]
233+
src = intercalate "\n"
234+
[ "10 if (.true.) then ! comment if"
235+
, " print *, 'foo'"
236+
, "20 else ! comment else"
237+
, " print *, 'foo'"
238+
, "30 endif ! comment end"
239+
]
237240
bParser src `shouldBe'` bl
238241

239242
describe "Legacy Extensions" $ do

0 commit comments

Comments
 (0)