From 048d86e77b8fee642310fe0ab9c6806d9fa599e2 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sat, 14 Oct 2017 17:17:44 +0300 Subject: [PATCH] Common stanzas --- Cabal/Cabal.cabal | 2 + .../PackageDescription/FieldGrammar.hs | 6 + .../Distribution/PackageDescription/Parsec.hs | 158 ++++++++++++++++-- Cabal/tests/ParserTests.hs | 2 + .../ParserTests/regressions/common.cabal | 32 ++++ .../ParserTests/regressions/common.format | 22 +++ .../ParserTests/regressions/common2.cabal | 35 ++++ .../ParserTests/regressions/common2.format | 34 ++++ 8 files changed, 281 insertions(+), 10 deletions(-) create mode 100644 Cabal/tests/ParserTests/regressions/common.cabal create mode 100644 Cabal/tests/ParserTests/regressions/common.format create mode 100644 Cabal/tests/ParserTests/regressions/common2.cabal create mode 100644 Cabal/tests/ParserTests/regressions/common2.format diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index 17b2b7478e7..97ce7a8d900 100644 --- a/Cabal/Cabal.cabal +++ b/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 diff --git a/Cabal/Distribution/PackageDescription/FieldGrammar.hs b/Cabal/Distribution/PackageDescription/FieldGrammar.hs index 578883824f7..ef969965532 100644 --- a/Cabal/Distribution/PackageDescription/FieldGrammar.hs +++ b/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 #-} diff --git a/Cabal/Distribution/PackageDescription/Parsec.hs b/Cabal/Distribution/PackageDescription/Parsec.hs index 53166f7179f..c99521ad7f6 100644 --- a/Cabal/Distribution/PackageDescription/Parsec.hs +++ b/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,7 +204,7 @@ 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 @@ -202,32 +212,32 @@ goSections hasElif = traverse_ process | 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 ------------------------------------------------------------------------------- diff --git a/Cabal/tests/ParserTests.hs b/Cabal/tests/ParserTests.hs index 68ea95fad51..f6b8a5b3630 100644 --- a/Cabal/tests/ParserTests.hs +++ b/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 diff --git a/Cabal/tests/ParserTests/regressions/common.cabal b/Cabal/tests/ParserTests/regressions/common.cabal new file mode 100644 index 00000000000..45c2c23fa74 --- /dev/null +++ b/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 diff --git a/Cabal/tests/ParserTests/regressions/common.format b/Cabal/tests/ParserTests/regressions/common.format new file mode 100644 index 00000000000..d6d40fa3413 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/Cabal/tests/ParserTests/regressions/common2.cabal b/Cabal/tests/ParserTests/regressions/common2.cabal new file mode 100644 index 00000000000..3c4a587347d --- /dev/null +++ b/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 diff --git a/Cabal/tests/ParserTests/regressions/common2.format b/Cabal/tests/ParserTests/regressions/common2.format new file mode 100644 index 00000000000..9db6ab8e4d5 --- /dev/null +++ b/Cabal/tests/ParserTests/regressions/common2.format @@ -0,0 +1,34 @@ +name: common +version: 0 +synopsis: Common-stanza demo demo +cabal-version: >=2.1 +build-type: Simple + +source-repository head + type: git + location: https://github.com/hvr/-.git + +library + exposed-modules: + ElseIf + default-language: Haskell2010 + build-depends: + base >=4.10 && <4.11, + containers -any, + ghc-prim -any + + if os(windows) + build-depends: + Win32 -any + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Tests.hs + build-depends: + base >=4.10 && <4.11, + containers -any, + HUnit -any + + if os(windows) + build-depends: + Win32 -any \ No newline at end of file