Skip to content

Commit b1b0cb1

Browse files
phadejphadej
committed
Common stanzas
1 parent 1e5bbe8 commit b1b0cb1

File tree

7 files changed

+213
-1
lines changed

7 files changed

+213
-1
lines changed

‎Cabal/Cabal.cabal

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -33,7 +33,10 @@ 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
39+
tests/ParserTests/regressions/elif2.cabal
3740
tests/ParserTests/regressions/encoding-0.8.cabal
3841
tests/ParserTests/regressions/generics-sop.cabal
3942
tests/ParserTests/regressions/issue-774.cabal

‎Cabal/Distribution/PackageDescription/Parsec.hs

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

153+
-- Common stanzas
154+
sectionFields' <-
155+
if specVersion pd >= mkVersion [2, 1]
156+
then spliceCommonStanzas sectionFields
157+
else pure sectionFields
158+
153159
-- elif conditional is accepted if spec version is >= 2.1
154160
let hasElif = if specVersion pd >= mkVersion [2,1] then HasElif else NoElif
155-
execStateT (goSections hasElif sectionFields) gpd
161+
execStateT (goSections hasElif sectionFields') gpd
156162
where
157163
emptyGpd :: GenericPackageDescription
158164
emptyGpd = GenericPackageDescription emptyPackageDescription [] Nothing [] [] [] [] []
@@ -263,6 +269,7 @@ goSections hasElif = traverse_ process
263269
| otherwise = inM $
264270
parseWarning pos PWTUnknownSection $ "Ignoring section: " ++ show name
265271

272+
-- TODO: use strict parser
266273
parseName :: Position -> [SectionArg Position] -> M String
267274
parseName pos args = case args of
268275
[SecArgName _pos secName] ->
@@ -277,6 +284,20 @@ parseName pos args = case args of
277284
inM $ parseFailure pos $ "Invalid name " ++ show args
278285
pure ""
279286

287+
parseCommonName :: Position -> [SectionArg Position] -> ParseResult String
288+
parseCommonName pos args = case args of
289+
[SecArgName _pos secName] ->
290+
pure $ fromUTF8BS secName
291+
[SecArgStr _pos secName] ->
292+
pure $ fromUTF8BS secName
293+
[] -> do
294+
parseFailure pos $ "name required"
295+
pure ""
296+
_ -> do
297+
-- TODO: pretty print args
298+
parseFailure pos $ "Invalid name " ++ show args
299+
pure ""
300+
280301
parseUnqualComponentName :: Position -> [SectionArg Position] -> M UnqualComponentName
281302
parseUnqualComponentName pos args = mkUnqualComponentName <$> parseName pos args
282303

@@ -369,6 +390,80 @@ When/if we re-implement the parser to support formatting preservging roundtrip
369390
with new AST, this all need to be rewritten.
370391
-}
371392

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

‎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)