Commit 6c2bdd6e authored by tibbe's avatar tibbe
Browse files

Parse 'benchmark' sections and handle configurations (flags) for benchmarks

parent 482d4fcd
......@@ -92,7 +92,10 @@ module Distribution.PackageDescription (
benchmarkType,
knownBenchmarkTypes,
emptyBenchmark,
hasBenchmarks,
withBenchmark,
benchmarkModules,
enabledBenchmarks,
-- * Build information
BuildInfo(..),
......@@ -184,6 +187,7 @@ data PackageDescription
library :: Maybe Library,
executables :: [Executable],
testSuites :: [TestSuite],
benchmarks :: [Benchmark],
dataFiles :: [FilePath],
dataDir :: FilePath,
extraSrcFiles :: [FilePath],
......@@ -246,6 +250,7 @@ emptyPackageDescription
library = Nothing,
executables = [],
testSuites = [],
benchmarks = [],
dataFiles = [],
dataDir = "",
extraSrcFiles = [],
......@@ -575,6 +580,19 @@ instance Monoid BenchmarkInterface where
emptyBenchmark :: Benchmark
emptyBenchmark = mempty
-- | Does this package have any benchmarks?
hasBenchmarks :: PackageDescription -> Bool
hasBenchmarks = any (buildable . benchmarkBuildInfo) . benchmarks
-- | Get all the enabled benchmarks from a package.
enabledBenchmarks :: PackageDescription -> [Benchmark]
enabledBenchmarks = filter benchmarkEnabled . benchmarks
-- | Perform an action on each buildable 'Benchmark' in a package.
withBenchmark :: PackageDescription -> (Benchmark -> IO ()) -> IO ()
withBenchmark pkg_descr f =
mapM_ f $ filter (buildable . benchmarkBuildInfo) $ enabledBenchmarks pkg_descr
-- | Get all the module names from a benchmark.
benchmarkModules :: Benchmark -> [ModuleName]
benchmarkModules benchmark = otherModules (benchmarkBuildInfo benchmark)
......@@ -716,7 +734,8 @@ emptyBuildInfo :: BuildInfo
emptyBuildInfo = mempty
-- | The 'BuildInfo' for the library (if there is one and it's buildable), and
-- all buildable executables, test suites and benchmarks. Useful for gathering
-- dependencies.
allBuildInfo :: PackageDescription -> [BuildInfo]
allBuildInfo pkg_descr = [ bi | Just lib <- [library pkg_descr]
, let bi = libBuildInfo lib
......@@ -728,6 +747,10 @@ allBuildInfo pkg_descr = [ bi | Just lib <- [library pkg_descr]
, let bi = testBuildInfo tst
, buildable bi
, testEnabled tst ]
++ [ bi | tst <- benchmarks pkg_descr
, let bi = benchmarkBuildInfo tst
, buildable bi
, benchmarkEnabled tst ]
--FIXME: many of the places where this is used, we actually want to look at
-- unbuildable bits too, probably need separate functions
......@@ -926,7 +949,8 @@ data GenericPackageDescription =
genPackageFlags :: [Flag],
condLibrary :: Maybe (CondTree ConfVar [Dependency] Library),
condExecutables :: [(String, CondTree ConfVar [Dependency] Executable)],
condTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)]
condTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)],
condBenchmarks :: [(String, CondTree ConfVar [Dependency] Benchmark)]
}
deriving (Show, Eq)
......
......@@ -68,7 +68,8 @@ import Distribution.PackageDescription
( GenericPackageDescription(..), PackageDescription(..)
, Library(..), Executable(..), BuildInfo(..)
, Flag(..), FlagName(..), FlagAssignment
, CondTree(..), ConfVar(..), Condition(..), TestSuite(..) )
, Benchmark(..), CondTree(..), ConfVar(..), Condition(..)
, TestSuite(..) )
import Distribution.Version
( VersionRange, anyVersion, intersectVersionRanges, withinRange )
import Distribution.Compiler
......@@ -399,12 +400,13 @@ newtype TargetSet a = TargetSet [(DependencyMap, a)]
overallDependencies :: TargetSet PDTagged -> DependencyMap
overallDependencies (TargetSet targets) = mconcat depss
where
(depss, _) = unzip $ filter (removeDisabledTests . snd) targets
removeDisabledTests :: PDTagged -> Bool
removeDisabledTests (Lib _) = True
removeDisabledTests (Exe _ _) = True
removeDisabledTests (Test _ t) = testEnabled t
removeDisabledTests PDNull = True
(depss, _) = unzip $ filter (removeDisabledSections . snd) targets
removeDisabledSections :: PDTagged -> Bool
removeDisabledSections (Lib _) = True
removeDisabledSections (Exe _ _) = True
removeDisabledSections (Test _ t) = testEnabled t
removeDisabledSections (Bench _ b) = benchmarkEnabled b
removeDisabledSections PDNull = True
-- Apply extra constraints to a dependency map.
-- Combines dependencies where the result will only contain keys from the left
......@@ -425,32 +427,46 @@ constrainBy left extra =
-- | Collect up the targets in a TargetSet of tagged targets, storing the
-- dependencies as we go.
flattenTaggedTargets :: TargetSet PDTagged ->
(Maybe Library, [(String, Executable)], [(String, TestSuite)])
flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], []) targets
(Maybe Library, [(String, Executable)], [(String, TestSuite)]
, [(String, Benchmark)])
flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], [], []) targets
where
untag (_, Lib _) (Just _, _, _) = bug "Only one library expected"
untag (deps, Lib l) (Nothing, exes, tests) = (Just l', exes, tests)
untag (_, Lib _) (Just _, _, _, _) = bug "Only one library expected"
untag (deps, Lib l) (Nothing, exes, tests, bms) =
(Just l', exes, tests, bms)
where
l' = l {
libBuildInfo = (libBuildInfo l) { targetBuildDepends = fromDepMap deps }
}
untag (deps, Exe n e) (mlib, exes, tests)
untag (deps, Exe n e) (mlib, exes, tests, bms)
| any ((== n) . fst) exes = bug "Exe with same name found"
| any ((== n) . fst) tests = bug "Test sharing name of exe found"
| otherwise = (mlib, exes ++ [(n, e')], tests)
| any ((== n) . fst) bms = bug "Benchmark sharing name of exe found"
| otherwise = (mlib, exes ++ [(n, e')], tests, bms)
where
e' = e {
buildInfo = (buildInfo e) { targetBuildDepends = fromDepMap deps }
}
untag (deps, Test n t) (mlib, exes, tests)
untag (deps, Test n t) (mlib, exes, tests, bms)
| any ((== n) . fst) tests = bug "Test with same name found"
| any ((== n) . fst) exes = bug "Test sharing name of exe found"
| otherwise = (mlib, exes, tests ++ [(n, t')])
| any ((== n) . fst) bms = bug "Test sharing name of benchmark found"
| otherwise = (mlib, exes, tests ++ [(n, t')], bms)
where
t' = t {
testBuildInfo = (testBuildInfo t)
{ targetBuildDepends = fromDepMap deps }
}
untag (deps, Bench n b) (mlib, exes, tests, bms)
| any ((== n) . fst) bms = bug "Benchmark with same name found"
| any ((== n) . fst) exes = bug "Benchmark sharing name of exe found"
| any ((== n) . fst) tests = bug "Benchmark sharing name of test found"
| otherwise = (mlib, exes, tests, bms ++ [(n, b')])
where
b' = b {
benchmarkBuildInfo = (benchmarkBuildInfo b)
{ targetBuildDepends = fromDepMap deps }
}
untag (_, PDNull) x = x -- actually this should not happen, but let's be liberal
......@@ -458,7 +474,12 @@ flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], []) targets
-- Convert GenericPackageDescription to PackageDescription
--
data PDTagged = Lib Library | Exe String Executable | Test String TestSuite | PDNull deriving Show
data PDTagged = Lib Library
| Exe String Executable
| Test String TestSuite
| Bench String Benchmark
| PDNull
deriving Show
instance Monoid PDTagged where
mempty = PDNull
......@@ -467,6 +488,7 @@ instance Monoid PDTagged where
Lib l `mappend` Lib l' = Lib (l `mappend` l')
Exe n e `mappend` Exe n' e' | n == n' = Exe n (e `mappend` e')
Test n t `mappend` Test n' t' | n == n' = Test n (t `mappend` t')
Bench n b `mappend` Bench n' b' | n == n' = Bench n (b `mappend` b')
_ `mappend` _ = bug "Cannot combine incompatible tags"
-- | Create a package description with all configurations resolved.
......@@ -503,12 +525,13 @@ finalizePackageDescription ::
-- ^ Either missing dependencies or the resolved package
-- description along with the flag assignments chosen.
finalizePackageDescription userflags satisfyDep (Platform arch os) impl constraints
(GenericPackageDescription pkg flags mlib0 exes0 tests0) =
(GenericPackageDescription pkg flags mlib0 exes0 tests0 bms0) =
case resolveFlags of
Right ((mlib, exes', tests'), targetSet, flagVals) ->
Right ((mlib, exes', tests', bms'), targetSet, flagVals) ->
Right ( pkg { library = mlib
, executables = exes'
, testSuites = tests'
, benchmarks = bms'
, buildDepends = fromDepMap (overallDependencies targetSet)
--TODO: we need to find a way to avoid pulling in deps
-- for non-buildable components. However cannot simply
......@@ -523,14 +546,16 @@ finalizePackageDescription userflags satisfyDep (Platform arch os) impl constrai
condTrees = maybeToList (fmap (mapTreeData Lib) mlib0 )
++ map (\(name,tree) -> mapTreeData (Exe name) tree) exes0
++ map (\(name,tree) -> mapTreeData (Test name) tree) tests0
++ map (\(name,tree) -> mapTreeData (Bench name) tree) bms0
resolveFlags =
case resolveWithFlags flagChoices os arch impl constraints condTrees check of
Right (targetSet, fs) ->
let (mlib, exes, tests) = flattenTaggedTargets targetSet in
let (mlib, exes, tests, bms) = flattenTaggedTargets targetSet in
Right ( (fmap libFillInDefaults mlib,
map (\(n,e) -> (exeFillInDefaults e) { exeName = n }) exes,
map (\(n,t) -> (testFillInDefaults t) { testName = n }) tests),
map (\(n,t) -> (testFillInDefaults t) { testName = n }) tests,
map (\(n,b) -> (benchFillInDefaults b) { benchmarkName = n }) bms),
targetSet, fs)
Left missing -> Left missing
......@@ -569,11 +594,12 @@ resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribu
-- default path will be missing from the package description returned by this
-- function.
flattenPackageDescription :: GenericPackageDescription -> PackageDescription
flattenPackageDescription (GenericPackageDescription pkg _ mlib0 exes0 tests0) =
flattenPackageDescription (GenericPackageDescription pkg _ mlib0 exes0 tests0 bms0) =
pkg { library = mlib
, executables = reverse exes
, testSuites = reverse tests
, buildDepends = ldeps ++ reverse edeps ++ reverse tdeps
, benchmarks = reverse bms
, buildDepends = ldeps ++ reverse edeps ++ reverse tdeps ++ reverse bdeps
}
where
(mlib, ldeps) = case mlib0 of
......@@ -582,12 +608,16 @@ flattenPackageDescription (GenericPackageDescription pkg _ mlib0 exes0 tests0) =
Nothing -> (Nothing, [])
(exes, edeps) = foldr flattenExe ([],[]) exes0
(tests, tdeps) = foldr flattenTst ([],[]) tests0
(bms, bdeps) = foldr flattenBm ([],[]) bms0
flattenExe (n, t) (es, ds) =
let (e, ds') = ignoreConditions t in
( (exeFillInDefaults $ e { exeName = n }) : es, ds' ++ ds )
flattenTst (n, t) (es, ds) =
let (e, ds') = ignoreConditions t in
( (testFillInDefaults $ e { testName = n }) : es, ds' ++ ds )
flattenBm (n, t) (es, ds) =
let (e, ds') = ignoreConditions t in
( (benchFillInDefaults $ e { benchmarkName = n }) : es, ds' ++ ds )
-- This is in fact rather a hack. The original version just overrode the
-- default values, however, when adding conditions we had to switch to a
......@@ -608,6 +638,10 @@ testFillInDefaults :: TestSuite -> TestSuite
testFillInDefaults tst@(TestSuite { testBuildInfo = bi }) =
tst { testBuildInfo = biFillInDefaults bi }
benchFillInDefaults :: Benchmark -> Benchmark
benchFillInDefaults bm@(Benchmark { benchmarkBuildInfo = bi }) =
bm { benchmarkBuildInfo = biFillInDefaults bi }
biFillInDefaults :: BuildInfo -> BuildInfo
biFillInDefaults bi =
if null (hsSourceDirs bi)
......
......@@ -304,6 +304,80 @@ validateTestSuite line stanza =
++ display tt ++ "' test suite type."
-- ---------------------------------------------------------------------------
-- The Benchmark type
-- | An intermediate type just used for parsing the benchmark stanza.
-- After validation it is converted into the proper 'Benchmark' type.
data BenchmarkStanza = BenchmarkStanza {
benchmarkStanzaBenchmarkType :: Maybe BenchmarkType,
benchmarkStanzaMainIs :: Maybe FilePath,
benchmarkStanzaBenchmarkModule :: Maybe ModuleName,
benchmarkStanzaBuildInfo :: BuildInfo
}
emptyBenchmarkStanza :: BenchmarkStanza
emptyBenchmarkStanza = BenchmarkStanza Nothing Nothing Nothing mempty
benchmarkFieldDescrs :: [FieldDescr BenchmarkStanza]
benchmarkFieldDescrs =
[ simpleField "type"
(maybe empty disp) (fmap Just parse)
benchmarkStanzaBenchmarkType
(\x suite -> suite { benchmarkStanzaBenchmarkType = x })
, simpleField "main-is"
(maybe empty showFilePath) (fmap Just parseFilePathQ)
benchmarkStanzaMainIs
(\x suite -> suite { benchmarkStanzaMainIs = x })
]
++ map biToBenchmark binfoFieldDescrs
where
biToBenchmark = liftField benchmarkStanzaBuildInfo
(\bi suite -> suite { benchmarkStanzaBuildInfo = bi })
storeXFieldsBenchmark :: UnrecFieldParser BenchmarkStanza
storeXFieldsBenchmark (f@('x':'-':_), val)
t@(BenchmarkStanza { benchmarkStanzaBuildInfo = bi }) =
Just $ t {benchmarkStanzaBuildInfo =
bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}
storeXFieldsBenchmark _ _ = Nothing
validateBenchmark :: LineNo -> BenchmarkStanza -> ParseResult Benchmark
validateBenchmark line stanza =
case benchmarkStanzaBenchmarkType stanza of
Nothing -> return $
emptyBenchmark { benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza }
Just tt@(BenchmarkTypeUnknown _ _) ->
return emptyBenchmark {
benchmarkInterface = BenchmarkUnsupported tt,
benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza
}
Just tt | tt `notElem` knownBenchmarkTypes ->
return emptyBenchmark {
benchmarkInterface = BenchmarkUnsupported tt,
benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza
}
Just tt@(BenchmarkTypeExe ver) ->
case benchmarkStanzaMainIs stanza of
Nothing -> syntaxError line (missingField "main-is" tt)
Just file -> do
when (isJust (benchmarkStanzaBenchmarkModule stanza)) $
warning (extraField "benchmark-module" tt)
return emptyBenchmark {
benchmarkInterface = BenchmarkExeV10 ver file,
benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza
}
where
missingField name tt = "The '" ++ name ++ "' field is required for the "
++ display tt ++ " benchmark type."
extraField name tt = "The '" ++ name ++ "' field is not used for the '"
++ display tt ++ "' benchmark type."
-- ---------------------------------------------------------------------------
-- The BuildInfo type
......@@ -626,14 +700,14 @@ parsePackageDescription file = do
-- 'getBody' assumes that the remaining fields only consist of
-- flags, lib and exe sections.
(repos, flags, mlib, exes, tests) <- getBody
(repos, flags, mlib, exes, tests, bms) <- getBody
warnIfRest -- warn if getBody did not parse up to the last field.
-- warn about using old/new syntax with wrong cabal-version:
maybeWarnCabalVersion (not $ oldSyntax fields0) pkg
checkForUndefinedFlags flags mlib exes tests
return $ GenericPackageDescription
pkg { sourceRepos = repos }
flags mlib exes tests
flags mlib exes tests bms
where
oldSyntax flds = all isSimpleField flds
......@@ -740,7 +814,8 @@ parsePackageDescription file = do
getBody :: PM ([SourceRepo], [Flag]
,Maybe (CondTree ConfVar [Dependency] Library)
,[(String, CondTree ConfVar [Dependency] Executable)]
,[(String, CondTree ConfVar [Dependency] TestSuite)])
,[(String, CondTree ConfVar [Dependency] TestSuite)]
,[(String, CondTree ConfVar [Dependency] Benchmark)])
getBody = peekField >>= \mf -> case mf of
Just (Section line_no sec_type sec_label sec_fields)
| sec_type == "executable" -> do
......@@ -749,8 +824,8 @@ parsePackageDescription file = do
exename <- lift $ runP line_no "executable" parseTokenQ sec_label
flds <- collectFields parseExeFields sec_fields
skipField
(repos, flags, lib, exes, tests) <- getBody
return (repos, flags, lib, (exename, flds): exes, tests)
(repos, flags, lib, exes, tests, bms) <- getBody
return (repos, flags, lib, (exename, flds): exes, tests, bms)
| sec_type == "test-suite" -> do
when (null sec_label) $ lift $ syntaxError line_no
......@@ -791,8 +866,8 @@ parsePackageDescription file = do
if checkTestType emptyTestSuite flds
then do
skipField
(repos, flags, lib, exes, tests) <- getBody
return (repos, flags, lib, exes, (testname, flds) : tests)
(repos, flags, lib, exes, tests, bms) <- getBody
return (repos, flags, lib, exes, (testname, flds) : tests, bms)
else lift $ syntaxError line_no $
"Test suite \"" ++ testname
++ "\" is missing required field \"type\" or the field "
......@@ -800,15 +875,63 @@ parsePackageDescription file = do
++ "available test types are: "
++ intercalate ", " (map display knownTestTypes)
| sec_type == "benchmark" -> do
when (null sec_label) $ lift $ syntaxError line_no
"'benchmark' needs one argument (the benchmark's name)"
benchname <- lift $ runP line_no "benchmark" parseTokenQ sec_label
flds <- collectFields (parseBenchmarkFields line_no) sec_fields
-- Check that a valid benchmark type has been chosen. A type
-- field may be given inside a conditional block, so we must
-- check for that before complaining that a type field has not
-- been given. The benchmark must always have a valid type, so
-- we need to check both the 'then' and 'else' blocks, though
-- the blocks need not have the same type.
let checkBenchmarkType ts ct =
let ts' = mappend ts $ condTreeData ct
-- If a conditional has only a 'then' block and no
-- 'else' block, then it cannot have a valid type
-- in every branch, unless the type is specified at
-- a higher level in the tree.
checkComponent (_, _, Nothing) = False
-- If a conditional has a 'then' block and an 'else'
-- block, both must specify a benchmark type, unless the
-- type is specified higher in the tree.
checkComponent (_, t, Just e) =
checkBenchmarkType ts' t && checkBenchmarkType ts' e
-- Does the current node specify a benchmark type?
hasBenchmarkType = benchmarkInterface ts'
/= benchmarkInterface emptyBenchmark
components = condTreeComponents ct
-- If the current level of the tree specifies a type,
-- then we are done. If not, then one of the conditional
-- branches below the current node must specify a type.
-- Each node may have multiple immediate children; we
-- only one need one to specify a type because the
-- configure step uses 'mappend' to join together the
-- results of flag resolution.
in hasBenchmarkType || (any checkComponent components)
if checkBenchmarkType emptyBenchmark flds
then do
skipField
(repos, flags, lib, exes, tests, bms) <- getBody
return (repos, flags, lib, exes, tests, (benchname, flds) : bms)
else lift $ syntaxError line_no $
"Benchmark \"" ++ benchname
++ "\" is missing required field \"type\" or the field "
++ "is not present in all conditional branches. The "
++ "available benchmark types are: "
++ intercalate ", " (map display knownBenchmarkTypes)
| sec_type == "library" -> do
when (not (null sec_label)) $ lift $
syntaxError line_no "'library' expects no argument"
flds <- collectFields parseLibFields sec_fields
skipField
(repos, flags, lib, exes, tests) <- getBody
(repos, flags, lib, exes, tests, bms) <- getBody
when (isJust lib) $ lift $ syntaxError line_no
"There can only be one library section in a package description."
return (repos, flags, Just flds, exes, tests)
return (repos, flags, Just flds, exes, tests, bms)
| sec_type == "flag" -> do
when (null sec_label) $ lift $
......@@ -819,8 +942,8 @@ parsePackageDescription file = do
(MkFlag (FlagName (lowercase sec_label)) "" True False)
sec_fields
skipField
(repos, flags, lib, exes, tests) <- getBody
return (repos, flag:flags, lib, exes, tests)
(repos, flags, lib, exes, tests, bms) <- getBody
return (repos, flag:flags, lib, exes, tests, bms)
| sec_type == "source-repository" -> do
when (null sec_label) $ lift $ syntaxError line_no $
......@@ -844,8 +967,8 @@ parsePackageDescription file = do
})
sec_fields
skipField
(repos, flags, lib, exes, tests) <- getBody
return (repo:repos, flags, lib, exes, tests)
(repos, flags, lib, exes, tests, bms) <- getBody
return (repo:repos, flags, lib, exes, tests, bms)
| otherwise -> do
lift $ warning $ "Ignoring unknown section type: " ++ sec_type
......@@ -856,7 +979,7 @@ parsePackageDescription file = do
"Construct not supported at this position: " ++ show f
skipField
getBody
Nothing -> return ([], [], Nothing, [], [])
Nothing -> return ([], [], Nothing, [], [], [])
-- Extracts all fields in a block and returns a 'CondTree'.
--
......@@ -904,6 +1027,12 @@ parsePackageDescription file = do
emptyTestStanza fields
lift $ validateTestSuite line x
parseBenchmarkFields :: LineNo -> [Field] -> PM Benchmark
parseBenchmarkFields line fields = do
x <- lift $ parseFields benchmarkFieldDescrs storeXFieldsBenchmark
emptyBenchmarkStanza fields
lift $ validateBenchmark line x
checkForUndefinedFlags ::
[Flag] ->
Maybe (CondTree ConfVar [Dependency] Library) ->
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment