Skip to content

Commit 89492fd

Browse files
phadejphadej
committed
Common stanzas
1 parent 069a641 commit 89492fd

File tree

7 files changed

+212
-1
lines changed

7 files changed

+212
-1
lines changed

‎Cabal/Cabal.cabal

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -33,6 +33,8 @@ extra-source-files:
3333
-- Do NOT edit this section manually; instead, run the script.
3434
-- BEGIN gen-extra-source-files
3535
tests/ParserTests/regressions/Octree-0.5.cabal
36+
tests/ParserTests/regressions/common.cabal
37+
tests/ParserTests/regressions/common2.cabal
3638
tests/ParserTests/regressions/elif.cabal
3739
tests/ParserTests/regressions/elif2.cabal
3840
tests/ParserTests/regressions/encoding-0.8.cabal

‎Cabal/Distribution/PackageDescription/Parsec.hs

Lines changed: 96 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -147,9 +147,15 @@ parseGenericPackageDescription' lexWarnings fs = do
147147
-- Sections
148148
let gpd = emptyGpd & L.packageDescription .~ pd
149149

150+
-- Common stanzas
151+
sectionFields' <-
152+
if specVersion pd >= mkVersion [2, 1]
153+
then spliceCommonStanzas sectionFields
154+
else pure sectionFields
155+
150156
-- elif conditional is accepted if spec version is >= 2.1
151157
let hasElif = if specVersion pd >= mkVersion [2,1] then HasElif else NoElif
152-
execStateT (goSections hasElif sectionFields) gpd
158+
execStateT (goSections hasElif sectionFields') gpd
153159
where
154160
emptyGpd :: GenericPackageDescription
155161
emptyGpd = GenericPackageDescription emptyPackageDescription [] Nothing [] [] [] [] []
@@ -261,6 +267,7 @@ goSections hasElif = traverse_ process
261267
parseWarning pos PWTUnknownSection $ "Ignoring section: " ++ show name
262268

263269
parseName :: Position -> [SectionArg Position] -> SectionParser String
270+
-- TODO: use strict parser
264271
parseName pos args = case args of
265272
[SecArgName _pos secName] ->
266273
pure $ fromUTF8BS secName
@@ -274,6 +281,20 @@ parseName pos args = case args of
274281
lift $ parseFailure pos $ "Invalid name " ++ show args
275282
pure ""
276283

284+
parseCommonName :: Position -> [SectionArg Position] -> ParseResult String
285+
parseCommonName pos args = case args of
286+
[SecArgName _pos secName] ->
287+
pure $ fromUTF8BS secName
288+
[SecArgStr _pos secName] ->
289+
pure $ fromUTF8BS secName
290+
[] -> do
291+
parseFailure pos $ "name required"
292+
pure ""
293+
_ -> do
294+
-- TODO: pretty print args
295+
parseFailure pos $ "Invalid name " ++ show args
296+
pure ""
297+
277298
parseUnqualComponentName :: Position -> [SectionArg Position] -> SectionParser UnqualComponentName
278299
parseUnqualComponentName pos args = mkUnqualComponentName <$> parseName pos args
279300

@@ -366,6 +387,80 @@ When/if we re-implement the parser to support formatting preservging roundtrip
366387
with new AST, this all need to be rewritten.
367388
-}
368389

390+
-------------------------------------------------------------------------------
391+
-- Common stanzas
392+
-------------------------------------------------------------------------------
393+
394+
-- | Splice common stanzas.
395+
--
396+
-- The approach resembles CPP: @common@ sections define blocks, which are
397+
-- then spliced in place of @include@ sections.
398+
--
399+
-- == Example
400+
--
401+
-- @
402+
-- common deps
403+
-- build-depends: base ^>= 4.10
404+
--
405+
-- test-suite tests
406+
-- type: exitcode-stdio-1.0
407+
-- include deps
408+
-- main-is: Main.hs
409+
-- @
410+
--
411+
-- is transformed into
412+
--
413+
-- @
414+
-- test-suite tests
415+
-- type: exitcode-stdio-1.0
416+
-- build-depends: base ^>= 4.10
417+
-- main-is: Main.hs
418+
-- @
419+
--
420+
-- Pros of this approach is its simplicity. Drawbacks are
421+
--
422+
-- * common stanza is parsed multiple times. We could /compile/ common stanzas
423+
-- to e.g. @'BuildInfo' -> 'BuildInfo'@, but application of it in
424+
-- 'FieldGrammarParser' approach will be impossible in *between* of other fields.
425+
-- Applying common stanzas after 'parseCondTree' might be surprising!
426+
-- Note how @build-depends@ are spliced in the example above.
427+
--
428+
-- /TODO:/ we could warn about unused stanzas.
429+
--
430+
spliceCommonStanzas :: [Field Position] -> ParseResult [Field Position]
431+
spliceCommonStanzas = go Map.empty
432+
where
433+
go :: Map String [Field Position] -> [Field Position] -> ParseResult [Field Position]
434+
go _ [] = pure []
435+
go common (f@Field {} : fields) = (f :) <$> go common fields
436+
go common (Section (Name pos name) args secFields : fields) | name == "common" = do
437+
commonName <- parseCommonName pos args
438+
go (Map.insert commonName secFields common) fields
439+
go common (Section name args secFields : fields) = do
440+
secFields' <- splice common secFields
441+
fields' <- go common fields
442+
pure (Section name args secFields' : fields')
443+
444+
splice :: Map String [Field Position] -> [Field Position] -> ParseResult [Field Position]
445+
splice common = sgo where
446+
sgo [] = pure []
447+
sgo (f@Field {} : fields) = (f :) <$> sgo fields
448+
sgo (Section (Name pos name) args secFields : fields) | name == "include" = do
449+
unless (null secFields) $
450+
parseFailure pos "Non-empty include stanza"
451+
452+
commonName <- parseCommonName pos args
453+
case Map.lookup commonName common of
454+
Nothing -> do
455+
parseFailure pos $ "Undefined common stanza included: " ++ commonName
456+
sgo fields
457+
Just secFields' -> do
458+
(secFields' ++) <$> sgo fields
459+
sgo (Section name args secFields : fields) = do
460+
secFields' <- sgo secFields
461+
fields' <- sgo fields
462+
pure (Section name args secFields' : fields')
463+
369464
-------------------------------------------------------------------------------
370465
-- Old syntax
371466
-------------------------------------------------------------------------------

‎Cabal/tests/ParserTests.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -82,6 +82,8 @@ regressionTests = testGroup "regressions"
8282
, regressionTest "elif.cabal"
8383
, regressionTest "elif2.cabal"
8484
, regressionTest "shake.cabal"
85+
, regressionTest "common.cabal"
86+
, regressionTest "common2.cabal"
8587
]
8688

8789
regressionTest :: FilePath -> TestTree

‎Cabal/tests/ParserTests/regressions/common.cabal

Lines changed: 32 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,32 @@
1+
name: common
2+
version: 0
3+
synopsis: Common-stanza demo demo
4+
build-type: Simple
5+
cabal-version: >=1.10
6+
7+
source-repository head
8+
Type: git
9+
Location: https://github.com/hvr/-.git
10+
11+
common deps
12+
build-depends:
13+
base >=4.10 && <4.11,
14+
containers
15+
16+
library
17+
default-language: Haskell2010
18+
exposed-modules: ElseIf
19+
20+
include deps
21+
22+
build-depends:
23+
ghc-prim
24+
25+
test-suite tests
26+
type: exitcode-stdio-1.0
27+
main-is: Tests.hs
28+
29+
include deps
30+
31+
build-depends:
32+
HUnit

‎Cabal/tests/ParserTests/regressions/common.format

Lines changed: 22 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,22 @@
1+
name: common
2+
version: 0
3+
synopsis: Common-stanza demo demo
4+
cabal-version: >=1.10
5+
build-type: Simple
6+
7+
source-repository head
8+
type: git
9+
location: https://github.com/hvr/-.git
10+
11+
library
12+
exposed-modules:
13+
ElseIf
14+
default-language: Haskell2010
15+
build-depends:
16+
ghc-prim -any
17+
18+
test-suite tests
19+
type: exitcode-stdio-1.0
20+
main-is: Tests.hs
21+
build-depends:
22+
HUnit -any

‎Cabal/tests/ParserTests/regressions/common2.cabal

Lines changed: 32 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,32 @@
1+
name: common
2+
version: 0
3+
synopsis: Common-stanza demo demo
4+
build-type: Simple
5+
cabal-version: >=2.1
6+
7+
source-repository head
8+
Type: git
9+
Location: https://github.com/hvr/-.git
10+
11+
common deps
12+
build-depends:
13+
base >=4.10 && <4.11,
14+
containers
15+
16+
library
17+
default-language: Haskell2010
18+
exposed-modules: ElseIf
19+
20+
include deps
21+
22+
build-depends:
23+
ghc-prim
24+
25+
test-suite tests
26+
type: exitcode-stdio-1.0
27+
main-is: Tests.hs
28+
29+
include deps
30+
31+
build-depends:
32+
HUnit

‎Cabal/tests/ParserTests/regressions/common2.format

Lines changed: 26 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,26 @@
1+
name: common
2+
version: 0
3+
synopsis: Common-stanza demo demo
4+
cabal-version: >=2.1
5+
build-type: Simple
6+
7+
source-repository head
8+
type: git
9+
location: https://github.com/hvr/-.git
10+
11+
library
12+
exposed-modules:
13+
ElseIf
14+
default-language: Haskell2010
15+
build-depends:
16+
base >=4.10 && <4.11,
17+
containers -any,
18+
ghc-prim -any
19+
20+
test-suite tests
21+
type: exitcode-stdio-1.0
22+
main-is: Tests.hs
23+
build-depends:
24+
base >=4.10 && <4.11,
25+
containers -any,
26+
HUnit -any

0 commit comments

Comments
 (0)