Common stanzas

Cabal/Cabal.cabal

@@ -33,6 +33,8 @@ extra-source-files:
   -- Do NOT edit this section manually; instead, run the script.
   -- BEGIN gen-extra-source-files
   tests/ParserTests/regressions/Octree-0.5.cabal
+  tests/ParserTests/regressions/common.cabal
+  tests/ParserTests/regressions/common2.cabal
   tests/ParserTests/regressions/elif.cabal
   tests/ParserTests/regressions/elif2.cabal
   tests/ParserTests/regressions/encoding-0.8.cabal

Cabal/Distribution/PackageDescription/FieldGrammar.hs

@@ -175,6 +175,9 @@ data TestSuiteStanza = TestSuiteStanza
     , _testStanzaBuildInfo  :: BuildInfo
     }
 
+instance L.HasBuildInfo TestSuiteStanza where
+    buildInfo = testStanzaBuildInfo
+
 testStanzaTestType :: Lens' TestSuiteStanza (Maybe TestType)
 testStanzaTestType f s = fmap (\x -> s { _testStanzaTestType = x }) (f (_testStanzaTestType s))
 {-# INLINE testStanzaTestType #-}
@@ -274,6 +277,9 @@ data BenchmarkStanza = BenchmarkStanza
     , _benchmarkStanzaBuildInfo       :: BuildInfo
     }
 
+instance L.HasBuildInfo BenchmarkStanza where
+    buildInfo = benchmarkStanzaBuildInfo
+
 benchmarkStanzaBenchmarkType :: Lens' BenchmarkStanza (Maybe BenchmarkType)
 benchmarkStanzaBenchmarkType f s = fmap (\x -> s { _benchmarkStanzaBenchmarkType = x }) (f (_benchmarkStanzaBenchmarkType s))
 {-# INLINE benchmarkStanzaBenchmarkType #-}

Cabal/Distribution/PackageDescription/Parsec.hs

@@ -52,6 +52,7 @@ import           Distribution.Parsec.ParseResult
 import           Distribution.Simple.Utils                    (die', fromUTF8BS, warn)
 import           Distribution.Text                            (display)
 import           Distribution.Types.CondTree
+import           Distribution.Types.Dependency                (Dependency)
 import           Distribution.Types.ForeignLib
 import           Distribution.Types.UnqualComponentName
                  (UnqualComponentName, mkUnqualComponentName)
@@ -62,6 +63,7 @@ import           Distribution.Version
 import           System.Directory                             (doesFileExist)
 
 import           Distribution.Compat.Lens
+import qualified Distribution.Types.BuildInfo.Lens                 as L
 import qualified Distribution.Types.GenericPackageDescription.Lens as L
 import qualified Distribution.Types.PackageDescription.Lens        as L
 
@@ -149,7 +151,15 @@ parseGenericPackageDescription' lexWarnings fs = do
 
     -- elif conditional is accepted if spec version is >= 2.1
     let hasElif = if specVersion pd >= mkVersion [2,1] then HasElif else NoElif
-    execStateT (goSections hasElif sectionFields) gpd
+
+    -- Common stanzas
+    (sectionFields', commonStanzas) <-
+        if specVersion pd >= mkVersion [2, 1]
+        then partitionCommonStanzas hasElif sectionFields
+        else pure (sectionFields, Map.empty)
+
+    -- parse secitons
+    execStateT (goSections hasElif commonStanzas sectionFields') gpd
   where
     emptyGpd :: GenericPackageDescription
     emptyGpd = GenericPackageDescription emptyPackageDescription [] Nothing [] [] [] [] []
@@ -180,8 +190,8 @@ parseGenericPackageDescription' lexWarnings fs = do
     maybeWarnCabalVersion _ _ = return ()
 
     -- Sections
-goSections :: HasElif -> [Field Position] -> SectionParser ()
-goSections hasElif = traverse_ process
+goSections :: HasElif -> Map String CondTreeBuildInfo -> [Field Position] -> SectionParser ()
+goSections hasElif commonStanzas = traverse_ process
   where
     process (Field (Name pos name) _) =
         lift $ parseWarning pos PWTTrailingFields $
@@ -194,40 +204,40 @@ goSections hasElif = traverse_ process
     parseSection :: Name Position -> [SectionArg Position] -> [Field Position] -> SectionParser ()
     parseSection (Name pos name) args fields
         | name == "library" && null args = do
-            lib <- lift $ parseCondTree hasElif (libraryFieldGrammar Nothing) (targetBuildDepends . libBuildInfo) fields
+            lib <- lift $ parseCondTreeWithCommonStanzas hasElif (libraryFieldGrammar Nothing) commonStanzas fields
             -- TODO: check that library is defined once
             L.condLibrary ?= lib
 
         -- Sublibraries
         | name == "library" = do
             -- TODO: check cabal-version
             name' <- parseUnqualComponentName pos args
-            lib   <- lift $ parseCondTree hasElif (libraryFieldGrammar $ Just name') (targetBuildDepends . libBuildInfo) fields
+            lib   <- lift $ parseCondTreeWithCommonStanzas hasElif (libraryFieldGrammar $ Just name') commonStanzas fields
             -- TODO check duplicate name here?
             L.condSubLibraries %= snoc (name', lib)
 
         | name == "foreign-library" = do
             name' <- parseUnqualComponentName pos args
-            flib  <- lift $ parseCondTree hasElif (foreignLibFieldGrammar name') (targetBuildDepends . foreignLibBuildInfo) fields
+            flib  <- lift $ parseCondTreeWithCommonStanzas hasElif (foreignLibFieldGrammar name') commonStanzas fields
             -- TODO check duplicate name here?
             L.condForeignLibs %= snoc (name', flib)
 
         | name == "executable" = do
             name' <- parseUnqualComponentName pos args
-            exe   <- lift $ parseCondTree hasElif (executableFieldGrammar name') (targetBuildDepends . buildInfo) fields
+            exe   <- lift $ parseCondTreeWithCommonStanzas hasElif (executableFieldGrammar name') commonStanzas fields
             -- TODO check duplicate name here?
             L.condExecutables %= snoc (name', exe)
 
         | name == "test-suite" = do
             name'      <- parseUnqualComponentName pos args
-            testStanza <- lift $ parseCondTree hasElif testSuiteFieldGrammar (targetBuildDepends . _testStanzaBuildInfo) fields
+            testStanza <- lift $ parseCondTreeWithCommonStanzas hasElif testSuiteFieldGrammar commonStanzas fields
             testSuite  <- lift $ traverse (validateTestSuite pos) testStanza
             -- TODO check duplicate name here?
             L.condTestSuites %= snoc (name', testSuite)
 
         | name == "benchmark" = do
             name'       <- parseUnqualComponentName pos args
-            benchStanza <- lift $ parseCondTree hasElif benchmarkFieldGrammar (targetBuildDepends . _benchmarkStanzaBuildInfo) fields
+            benchStanza <- lift $ parseCondTreeWithCommonStanzas hasElif benchmarkFieldGrammar commonStanzas fields
             bench       <- lift $ traverse (validateBenchmark pos) benchStanza
             -- TODO check duplicate name here?
             L.condBenchmarks %= snoc (name', bench)
@@ -261,6 +271,7 @@ goSections hasElif = traverse_ process
             parseWarning pos PWTUnknownSection $ "Ignoring section: " ++ show name
 
 parseName :: Position -> [SectionArg Position] -> SectionParser String
+-- TODO: use strict parser
 parseName pos args = case args of
     [SecArgName _pos secName] ->
          pure $ fromUTF8BS secName
@@ -274,6 +285,20 @@ parseName pos args = case args of
          lift $ parseFailure pos $ "Invalid name " ++ show args
          pure ""
 
+parseCommonName :: Position -> [SectionArg Position] -> ParseResult String
+parseCommonName pos args = case args of
+    [SecArgName _pos secName] ->
+         pure $ fromUTF8BS secName
+    [SecArgStr _pos secName] ->
+         pure $ fromUTF8BS secName
+    [] -> do
+         parseFailure pos $ "name required"
+         pure ""
+    _ -> do
+         -- TODO: pretty print args
+         parseFailure pos $ "Invalid name " ++ show args
+         pure ""
+
 parseUnqualComponentName :: Position -> [SectionArg Position] -> SectionParser UnqualComponentName
 parseUnqualComponentName pos args = mkUnqualComponentName <$> parseName pos args
 
@@ -291,10 +316,10 @@ warnInvalidSubsection :: Section Position -> ParseResult ()
 warnInvalidSubsection (MkSection (Name pos name) _ _) =
     void (parseFailure pos $ "invalid subsection " ++ show name)
 
-
 data HasElif = HasElif | NoElif
   deriving (Eq, Show)
 
+-- TODO: add warning about include section
 parseCondTree
     :: forall a c.
        HasElif                -- ^ accept @elif@
@@ -366,6 +391,119 @@ When/if we re-implement the parser to support formatting preservging roundtrip
 with new AST, this all need to be rewritten.
 -}
 
+-------------------------------------------------------------------------------
+-- Common stanzas
+-------------------------------------------------------------------------------
+
+-- $commonStanzas
+--
+-- [Note: Common stanzas]
+--
+-- In Cabal 2.2 we support simple common stanzas:
+--
+-- * Commons stanzas define 'BuildInfo'
+--
+-- * Include statements can only occur at top of other stanzas (think: imports)
+--
+-- In particular __there aren't__
+--
+-- * implicit stanzas
+--
+-- * More specific common stanzas (executable, test-suite).
+--
+-- 
+-- The approach uses the fact that 'BuildInfo' is a 'Monoid':
+--
+-- @
+-- mergeCommonStanza' :: HasBuildInfo comp => BuildInfo -> comp -> comp
+-- mergeCommonStanza' bi = over L.BuildInfo (bi <>)
+-- @
+--
+-- Real 'mergeCommonStanza' is more complicated as we have to deal with
+-- conditional trees.
+--
+-- The approach is simple, and have good properties:
+--
+-- * Common stanzas are parsed exactly once, even if not-used. Thus we report errors in them.
+--
+type CondTreeBuildInfo = CondTree ConfVar [Dependency] BuildInfo
+
+-- | Create @a@ from 'BuildInfo'.
+--
+-- Law: @view buildInfo . fromBuildInfo = id@
+class L.HasBuildInfo a => FromBuildInfo a where
+    fromBuildInfo :: BuildInfo -> a
+
+instance FromBuildInfo Library    where fromBuildInfo bi = set L.buildInfo bi emptyLibrary
+instance FromBuildInfo ForeignLib where fromBuildInfo bi = set L.buildInfo bi emptyForeignLib
+instance FromBuildInfo Executable where fromBuildInfo bi = set L.buildInfo bi emptyExecutable
+
+instance FromBuildInfo TestSuiteStanza where 
+    fromBuildInfo = TestSuiteStanza Nothing Nothing Nothing
+
+instance FromBuildInfo BenchmarkStanza where 
+    fromBuildInfo = BenchmarkStanza Nothing Nothing Nothing
+
+partitionCommonStanzas :: HasElif -> [Field Position] -> ParseResult ([Field Position], Map String CondTreeBuildInfo)
+partitionCommonStanzas _hasElif [] = pure ([], Map.empty)
+partitionCommonStanzas hasElif (Section (Name pos name) args secFields : fields) | name == "common" = do
+    commonName <- parseCommonName pos args
+    biTree <- parseCondTree hasElif buildInfoFieldGrammar targetBuildDepends secFields
+
+    (fs, m) <- partitionCommonStanzas hasElif fields
+
+    -- TODO: check duplicate name
+    pure (fs, Map.insert commonName biTree m)
+
+-- | Other fields fall through:
+partitionCommonStanzas hasElif (field : fields) = do
+    (fs, m) <- partitionCommonStanzas hasElif fields
+    pure (field : fs, m)
+
+parseCondTreeWithCommonStanzas
+    :: forall a. FromBuildInfo a
+    => HasElif                       -- ^ accept @elif@
+    -> ParsecFieldGrammar' a         -- ^ grammar
+    -> Map String CondTreeBuildInfo  -- ^ common stanzas
+    -> [Field Position]
+    -> ParseResult (CondTree ConfVar [Dependency] a)
+parseCondTreeWithCommonStanzas hasElif grammar commonStanzas = goIncludes []
+  where
+    -- parse leading includes
+    goIncludes acc (Section (Name pos name) args secFields : fields) | name == "include" = do
+        unless (null secFields) $
+            parseFailure pos "Non-empty include stanza"
+        commonName <- parseCommonName pos args
+        case Map.lookup commonName commonStanzas of
+            Nothing -> do
+                parseFailure pos $ "Undefined common stanza included: " ++ commonName
+                goIncludes acc fields
+            Just commonTree -> 
+                goIncludes (acc ++ [commonTree]) fields
+
+    -- Go to parsing condTree after first non-include 'Field'.
+    goIncludes acc fields = go acc fields
+
+    -- parse actual CondTree
+    go :: [CondTreeBuildInfo] -> [Field Position] -> ParseResult (CondTree ConfVar [Dependency] a)
+    go bis fields = do
+        x <- parseCondTree hasElif grammar (view L.targetBuildDepends) fields
+        pure $ foldr mergeCommonStanza x bis
+
+mergeCommonStanza
+    :: forall a. FromBuildInfo a
+    => CondTree ConfVar [Dependency] BuildInfo
+    -> CondTree ConfVar [Dependency] a
+    -> CondTree ConfVar [Dependency] a
+mergeCommonStanza (CondNode bi _ bis) (CondNode x _ cs) =
+    CondNode x' (x' ^. L.targetBuildDepends) cs'
+  where
+    -- new value is old value with buildInfo field _prepended_.
+    x' = x & L.buildInfo %~ (bi <>)
+
+    -- tree components are appended together.
+    cs' = map (fmap fromBuildInfo) bis ++ cs
+
 -------------------------------------------------------------------------------
 -- Old syntax
 -------------------------------------------------------------------------------

Cabal/tests/ParserTests.hs

@@ -83,6 +83,8 @@ regressionTests = testGroup "regressions"
     , regressionTest "elif.cabal"
     , regressionTest "elif2.cabal"
     , regressionTest "shake.cabal"
+    , regressionTest "common.cabal"
+    , regressionTest "common2.cabal"
     ]
 
 regressionTest :: FilePath -> TestTree

Cabal/tests/ParserTests/regressions/common.cabal

@@ -0,0 +1,32 @@
+name:                common
+version:             0
+synopsis:            Common-stanza demo demo
+build-type:          Simple
+cabal-version:       >=1.10
+
+source-repository head
+  Type:     git
+  Location: https://github.com/hvr/-.git
+
+common deps
+  build-depends:
+    base >=4.10 && <4.11,
+    containers
+
+library
+  default-language: Haskell2010
+  exposed-modules:  ElseIf
+
+  include deps
+
+  build-depends:
+    ghc-prim
+
+test-suite tests
+  type: exitcode-stdio-1.0
+  main-is: Tests.hs
+
+  include deps
+
+  build-depends:
+    HUnit

Cabal/tests/ParserTests/regressions/common.format

@@ -0,0 +1,22 @@
+name: common
+version: 0
+synopsis: Common-stanza demo demo
+cabal-version: >=1.10
+build-type: Simple
+
+source-repository head
+    type: git
+    location: https://github.com/hvr/-.git
+
+library
+    exposed-modules:
+        ElseIf
+    default-language: Haskell2010
+    build-depends:
+        ghc-prim -any
+
+test-suite tests
+    type: exitcode-stdio-1.0
+    main-is: Tests.hs
+    build-depends:
+        HUnit -any

Cabal/tests/ParserTests/regressions/common2.cabal

@@ -0,0 +1,35 @@
+name:                common
+version:             0
+synopsis:            Common-stanza demo demo
+build-type:          Simple
+cabal-version:       >=2.1
+
+source-repository head
+  Type:     git
+  Location: https://github.com/hvr/-.git
+
+common deps
+  build-depends:
+    base >=4.10 && <4.11,
+    containers
+
+  if os(windows)
+    build-depends: Win32
+
+library
+  include deps
+
+  default-language: Haskell2010
+  exposed-modules:  ElseIf
+
+  build-depends:
+    ghc-prim
+
+test-suite tests
+  include deps
+
+  type: exitcode-stdio-1.0
+  main-is: Tests.hs
+
+  build-depends:
+    HUnit