Skip to content

Commit 048d86e

Browse files
phadejphadej
committed
Common stanzas
1 parent 2493a56 commit 048d86e

File tree

8 files changed

+281
-10
lines changed

8 files changed

+281
-10
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/FieldGrammar.hs

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -175,6 +175,9 @@ data TestSuiteStanza = TestSuiteStanza
175175
, _testStanzaBuildInfo :: BuildInfo
176176
}
177177

178+
instance L.HasBuildInfo TestSuiteStanza where
179+
buildInfo = testStanzaBuildInfo
180+
178181
testStanzaTestType :: Lens' TestSuiteStanza (Maybe TestType)
179182
testStanzaTestType f s = fmap (\x -> s { _testStanzaTestType = x }) (f (_testStanzaTestType s))
180183
{-# INLINE testStanzaTestType #-}
@@ -274,6 +277,9 @@ data BenchmarkStanza = BenchmarkStanza
274277
, _benchmarkStanzaBuildInfo :: BuildInfo
275278
}
276279

280+
instance L.HasBuildInfo BenchmarkStanza where
281+
buildInfo = benchmarkStanzaBuildInfo
282+
277283
benchmarkStanzaBenchmarkType :: Lens' BenchmarkStanza (Maybe BenchmarkType)
278284
benchmarkStanzaBenchmarkType f s = fmap (\x -> s { _benchmarkStanzaBenchmarkType = x }) (f (_benchmarkStanzaBenchmarkType s))
279285
{-# INLINE benchmarkStanzaBenchmarkType #-}

‎Cabal/Distribution/PackageDescription/Parsec.hs

Lines changed: 148 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -52,6 +52,7 @@ import Distribution.Parsec.ParseResult
5252
import Distribution.Simple.Utils (die', fromUTF8BS, warn)
5353
import Distribution.Text (display)
5454
import Distribution.Types.CondTree
55+
import Distribution.Types.Dependency (Dependency)
5556
import Distribution.Types.ForeignLib
5657
import Distribution.Types.UnqualComponentName
5758
(UnqualComponentName, mkUnqualComponentName)
@@ -62,6 +63,7 @@ import Distribution.Version
6263
import System.Directory (doesFileExist)
6364

6465
import Distribution.Compat.Lens
66+
import qualified Distribution.Types.BuildInfo.Lens as L
6567
import qualified Distribution.Types.GenericPackageDescription.Lens as L
6668
import qualified Distribution.Types.PackageDescription.Lens as L
6769

@@ -149,7 +151,15 @@ parseGenericPackageDescription' lexWarnings fs = do
149151

150152
-- elif conditional is accepted if spec version is >= 2.1
151153
let hasElif = if specVersion pd >= mkVersion [2,1] then HasElif else NoElif
152-
execStateT (goSections hasElif sectionFields) gpd
154+
155+
-- Common stanzas
156+
(sectionFields', commonStanzas) <-
157+
if specVersion pd >= mkVersion [2, 1]
158+
then partitionCommonStanzas hasElif sectionFields
159+
else pure (sectionFields, Map.empty)
160+
161+
-- parse secitons
162+
execStateT (goSections hasElif commonStanzas sectionFields') gpd
153163
where
154164
emptyGpd :: GenericPackageDescription
155165
emptyGpd = GenericPackageDescription emptyPackageDescription [] Nothing [] [] [] [] []
@@ -180,8 +190,8 @@ parseGenericPackageDescription' lexWarnings fs = do
180190
maybeWarnCabalVersion _ _ = return ()
181191

182192
-- Sections
183-
goSections :: HasElif -> [Field Position] -> SectionParser ()
184-
goSections hasElif = traverse_ process
193+
goSections :: HasElif -> Map String CondTreeBuildInfo -> [Field Position] -> SectionParser ()
194+
goSections hasElif commonStanzas = traverse_ process
185195
where
186196
process (Field (Name pos name) _) =
187197
lift $ parseWarning pos PWTTrailingFields $
@@ -194,40 +204,40 @@ goSections hasElif = traverse_ process
194204
parseSection :: Name Position -> [SectionArg Position] -> [Field Position] -> SectionParser ()
195205
parseSection (Name pos name) args fields
196206
| name == "library" && null args = do
197-
lib <- lift $ parseCondTree hasElif (libraryFieldGrammar Nothing) (targetBuildDepends . libBuildInfo) fields
207+
lib <- lift $ parseCondTreeWithCommonStanzas hasElif (libraryFieldGrammar Nothing) commonStanzas fields
198208
-- TODO: check that library is defined once
199209
L.condLibrary ?= lib
200210

201211
-- Sublibraries
202212
| name == "library" = do
203213
-- TODO: check cabal-version
204214
name' <- parseUnqualComponentName pos args
205-
lib <- lift $ parseCondTree hasElif (libraryFieldGrammar $ Just name') (targetBuildDepends . libBuildInfo) fields
215+
lib <- lift $ parseCondTreeWithCommonStanzas hasElif (libraryFieldGrammar $ Just name') commonStanzas fields
206216
-- TODO check duplicate name here?
207217
L.condSubLibraries %= snoc (name', lib)
208218

209219
| name == "foreign-library" = do
210220
name' <- parseUnqualComponentName pos args
211-
flib <- lift $ parseCondTree hasElif (foreignLibFieldGrammar name') (targetBuildDepends . foreignLibBuildInfo) fields
221+
flib <- lift $ parseCondTreeWithCommonStanzas hasElif (foreignLibFieldGrammar name') commonStanzas fields
212222
-- TODO check duplicate name here?
213223
L.condForeignLibs %= snoc (name', flib)
214224

215225
| name == "executable" = do
216226
name' <- parseUnqualComponentName pos args
217-
exe <- lift $ parseCondTree hasElif (executableFieldGrammar name') (targetBuildDepends . buildInfo) fields
227+
exe <- lift $ parseCondTreeWithCommonStanzas hasElif (executableFieldGrammar name') commonStanzas fields
218228
-- TODO check duplicate name here?
219229
L.condExecutables %= snoc (name', exe)
220230

221231
| name == "test-suite" = do
222232
name' <- parseUnqualComponentName pos args
223-
testStanza <- lift $ parseCondTree hasElif testSuiteFieldGrammar (targetBuildDepends . _testStanzaBuildInfo) fields
233+
testStanza <- lift $ parseCondTreeWithCommonStanzas hasElif testSuiteFieldGrammar commonStanzas fields
224234
testSuite <- lift $ traverse (validateTestSuite pos) testStanza
225235
-- TODO check duplicate name here?
226236
L.condTestSuites %= snoc (name', testSuite)
227237

228238
| name == "benchmark" = do
229239
name' <- parseUnqualComponentName pos args
230-
benchStanza <- lift $ parseCondTree hasElif benchmarkFieldGrammar (targetBuildDepends . _benchmarkStanzaBuildInfo) fields
240+
benchStanza <- lift $ parseCondTreeWithCommonStanzas hasElif benchmarkFieldGrammar commonStanzas fields
231241
bench <- lift $ traverse (validateBenchmark pos) benchStanza
232242
-- TODO check duplicate name here?
233243
L.condBenchmarks %= snoc (name', bench)
@@ -261,6 +271,7 @@ goSections hasElif = traverse_ process
261271
parseWarning pos PWTUnknownSection $ "Ignoring section: " ++ show name
262272

263273
parseName :: Position -> [SectionArg Position] -> SectionParser String
274+
-- TODO: use strict parser
264275
parseName pos args = case args of
265276
[SecArgName _pos secName] ->
266277
pure $ fromUTF8BS secName
@@ -274,6 +285,20 @@ parseName pos args = case args of
274285
lift $ parseFailure pos $ "Invalid name " ++ show args
275286
pure ""
276287

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

@@ -291,10 +316,10 @@ warnInvalidSubsection :: Section Position -> ParseResult ()
291316
warnInvalidSubsection (MkSection (Name pos name) _ _) =
292317
void (parseFailure pos $ "invalid subsection " ++ show name)
293318

294-
295319
data HasElif = HasElif | NoElif
296320
deriving (Eq, Show)
297321

322+
-- TODO: add warning about include section
298323
parseCondTree
299324
:: forall a c.
300325
HasElif -- ^ accept @elif@
@@ -366,6 +391,119 @@ When/if we re-implement the parser to support formatting preservging roundtrip
366391
with new AST, this all need to be rewritten.
367392
-}
368393

394+
-------------------------------------------------------------------------------
395+
-- Common stanzas
396+
-------------------------------------------------------------------------------
397+
398+
-- $commonStanzas
399+
--
400+
-- [Note: Common stanzas]
401+
--
402+
-- In Cabal 2.2 we support simple common stanzas:
403+
--
404+
-- * Commons stanzas define 'BuildInfo'
405+
--
406+
-- * Include statements can only occur at top of other stanzas (think: imports)
407+
--
408+
-- In particular __there aren't__
409+
--
410+
-- * implicit stanzas
411+
--
412+
-- * More specific common stanzas (executable, test-suite).
413+
--
414+
--
415+
-- The approach uses the fact that 'BuildInfo' is a 'Monoid':
416+
--
417+
-- @
418+
-- mergeCommonStanza' :: HasBuildInfo comp => BuildInfo -> comp -> comp
419+
-- mergeCommonStanza' bi = over L.BuildInfo (bi <>)
420+
-- @
421+
--
422+
-- Real 'mergeCommonStanza' is more complicated as we have to deal with
423+
-- conditional trees.
424+
--
425+
-- The approach is simple, and have good properties:
426+
--
427+
-- * Common stanzas are parsed exactly once, even if not-used. Thus we report errors in them.
428+
--
429+
type CondTreeBuildInfo = CondTree ConfVar [Dependency] BuildInfo
430+
431+
-- | Create @a@ from 'BuildInfo'.
432+
--
433+
-- Law: @view buildInfo . fromBuildInfo = id@
434+
class L.HasBuildInfo a => FromBuildInfo a where
435+
fromBuildInfo :: BuildInfo -> a
436+
437+
instance FromBuildInfo Library where fromBuildInfo bi = set L.buildInfo bi emptyLibrary
438+
instance FromBuildInfo ForeignLib where fromBuildInfo bi = set L.buildInfo bi emptyForeignLib
439+
instance FromBuildInfo Executable where fromBuildInfo bi = set L.buildInfo bi emptyExecutable
440+
441+
instance FromBuildInfo TestSuiteStanza where
442+
fromBuildInfo = TestSuiteStanza Nothing Nothing Nothing
443+
444+
instance FromBuildInfo BenchmarkStanza where
445+
fromBuildInfo = BenchmarkStanza Nothing Nothing Nothing
446+
447+
partitionCommonStanzas :: HasElif -> [Field Position] -> ParseResult ([Field Position], Map String CondTreeBuildInfo)
448+
partitionCommonStanzas _hasElif [] = pure ([], Map.empty)
449+
partitionCommonStanzas hasElif (Section (Name pos name) args secFields : fields) | name == "common" = do
450+
commonName <- parseCommonName pos args
451+
biTree <- parseCondTree hasElif buildInfoFieldGrammar targetBuildDepends secFields
452+
453+
(fs, m) <- partitionCommonStanzas hasElif fields
454+
455+
-- TODO: check duplicate name
456+
pure (fs, Map.insert commonName biTree m)
457+
458+
-- | Other fields fall through:
459+
partitionCommonStanzas hasElif (field : fields) = do
460+
(fs, m) <- partitionCommonStanzas hasElif fields
461+
pure (field : fs, m)
462+
463+
parseCondTreeWithCommonStanzas
464+
:: forall a. FromBuildInfo a
465+
=> HasElif -- ^ accept @elif@
466+
-> ParsecFieldGrammar' a -- ^ grammar
467+
-> Map String CondTreeBuildInfo -- ^ common stanzas
468+
-> [Field Position]
469+
-> ParseResult (CondTree ConfVar [Dependency] a)
470+
parseCondTreeWithCommonStanzas hasElif grammar commonStanzas = goIncludes []
471+
where
472+
-- parse leading includes
473+
goIncludes acc (Section (Name pos name) args secFields : fields) | name == "include" = do
474+
unless (null secFields) $
475+
parseFailure pos "Non-empty include stanza"
476+
commonName <- parseCommonName pos args
477+
case Map.lookup commonName commonStanzas of
478+
Nothing -> do
479+
parseFailure pos $ "Undefined common stanza included: " ++ commonName
480+
goIncludes acc fields
481+
Just commonTree ->
482+
goIncludes (acc ++ [commonTree]) fields
483+
484+
-- Go to parsing condTree after first non-include 'Field'.
485+
goIncludes acc fields = go acc fields
486+
487+
-- parse actual CondTree
488+
go :: [CondTreeBuildInfo] -> [Field Position] -> ParseResult (CondTree ConfVar [Dependency] a)
489+
go bis fields = do
490+
x <- parseCondTree hasElif grammar (view L.targetBuildDepends) fields
491+
pure $ foldr mergeCommonStanza x bis
492+
493+
mergeCommonStanza
494+
:: forall a. FromBuildInfo a
495+
=> CondTree ConfVar [Dependency] BuildInfo
496+
-> CondTree ConfVar [Dependency] a
497+
-> CondTree ConfVar [Dependency] a
498+
mergeCommonStanza (CondNode bi _ bis) (CondNode x _ cs) =
499+
CondNode x' (x' ^. L.targetBuildDepends) cs'
500+
where
501+
-- new value is old value with buildInfo field _prepended_.
502+
x' = x & L.buildInfo %~ (bi <>)
503+
504+
-- tree components are appended together.
505+
cs' = map (fmap fromBuildInfo) bis ++ cs
506+
369507
-------------------------------------------------------------------------------
370508
-- Old syntax
371509
-------------------------------------------------------------------------------

‎Cabal/tests/ParserTests.hs

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

8890
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: 35 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,35 @@
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+
if os(windows)
17+
build-depends: Win32
18+
19+
library
20+
include deps
21+
22+
default-language: Haskell2010
23+
exposed-modules: ElseIf
24+
25+
build-depends:
26+
ghc-prim
27+
28+
test-suite tests
29+
include deps
30+
31+
type: exitcode-stdio-1.0
32+
main-is: Tests.hs
33+
34+
build-depends:
35+
HUnit

0 commit comments

Comments
 (0)