diff --git a/Cabal.cabal b/Cabal.cabal --- a/Cabal.cabal +++ b/Cabal.cabal @@ -1,5 +1,5 @@ Name: Cabal -Version: 1.12.0 +Version: 1.14.0 Copyright: 2003-2006, Isaac Jones 2005-2011, Duncan Coutts License: BSD3 @@ -29,6 +29,7 @@ source-repository head type: darcs location: http://darcs.haskell.org/cabal/ + subdir: Cabal Flag base4 Description: Choose the even newer, even smaller, split-up base package. @@ -38,15 +39,15 @@ Library build-depends: base >= 2 && < 5, - filepath >= 1 && < 1.3 + filepath >= 1 && < 1.4 if flag(base4) { build-depends: base >= 4 } else { build-depends: base < 4 } if flag(base3) { build-depends: base >= 3 } else { build-depends: base < 3 } if flag(base3) Build-Depends: directory >= 1 && < 1.2, process >= 1 && < 1.2, - old-time >= 1 && < 1.1, + old-time >= 1 && < 1.2, containers >= 0.1 && < 0.5, - array >= 0.1 && < 0.4, + array >= 0.1 && < 0.5, pretty >= 1 && < 1.2 if !os(windows) @@ -76,6 +77,7 @@ Distribution.Simple.Build.Macros, Distribution.Simple.Build.PathsModule, Distribution.Simple.BuildPaths, + Distribution.Simple.Bench, Distribution.Simple.Command, Distribution.Simple.Compiler, Distribution.Simple.Configure, @@ -97,6 +99,7 @@ Distribution.Simple.Program.Builtin, Distribution.Simple.Program.Db, Distribution.Simple.Program.HcPkg, + Distribution.Simple.Program.Hpc, Distribution.Simple.Program.Ld, Distribution.Simple.Program.Run, Distribution.Simple.Program.Script, @@ -142,8 +145,10 @@ PackageTests.BuildDeps.TargetSpecificDeps2.Check, PackageTests.BuildDeps.TargetSpecificDeps3.Check, PackageTests.BuildDeps.SameDepsAllRound.Check, + PackageTests.TestOptions.Check, PackageTests.TestStanza.Check, PackageTests.TestSuiteExeV10.Check, + PackageTests.BenchmarkStanza.Check, PackageTests.PackageTester hs-source-dirs: tests build-depends: diff --git a/Distribution/PackageDescription.hs b/Distribution/PackageDescription.hs --- a/Distribution/PackageDescription.hs +++ b/Distribution/PackageDescription.hs @@ -8,10 +8,10 @@ -- -- This defines the data structure for the @.cabal@ file format. There are -- several parts to this structure. It has top level info and then 'Library', --- 'Executable', and 'TestSuite' sections each of which have associated --- 'BuildInfo' data that's used to build the library, exe, or test. To further --- complicate things there is both a 'PackageDescription' and a --- 'GenericPackageDescription'. This distinction relates to cabal +-- 'Executable', 'TestSuite', and 'Benchmark' sections each of which have +-- associated 'BuildInfo' data that's used to build the library, exe, test, or +-- benchmark. To further complicate things there is both a 'PackageDescription' +-- and a 'GenericPackageDescription'. This distinction relates to cabal -- configurations. When we initially read a @.cabal@ file we get a -- 'GenericPackageDescription' which has all the conditional sections. -- Before actually building a package we have to decide @@ -85,6 +85,18 @@ testModules, enabledTests, + -- * Benchmarks + Benchmark(..), + BenchmarkInterface(..), + BenchmarkType(..), + benchmarkType, + knownBenchmarkTypes, + emptyBenchmark, + hasBenchmarks, + withBenchmark, + benchmarkModules, + enabledBenchmarks, + -- * Build information BuildInfo(..), emptyBuildInfo, @@ -115,7 +127,7 @@ import Data.Maybe (maybeToList) import Data.Monoid (Monoid(mempty, mappend)) import Control.Monad (MonadPlus(mplus)) -import Text.PrettyPrint.HughesPJ as Disp +import Text.PrettyPrint as Disp import qualified Distribution.Compat.ReadP as Parse import qualified Data.Char as Char (isAlphaNum, isDigit, toLower) @@ -175,6 +187,7 @@ library :: Maybe Library, executables :: [Executable], testSuites :: [TestSuite], + benchmarks :: [Benchmark], dataFiles :: [FilePath], dataDir :: FilePath, extraSrcFiles :: [FilePath], @@ -237,6 +250,7 @@ library = Nothing, executables = [], testSuites = [], + benchmarks = [], dataFiles = [], dataDir = "", extraSrcFiles = [], @@ -470,9 +484,7 @@ knownTestTypes :: [TestType] knownTestTypes = [ TestTypeExe (Version [1,0] []) - -- 'detailed-0.9' test type is disabled in Cabal-1.10.x - -- needs more work on the details of the library interface - {- , TestTypeLib (Version [0,9] []) -} ] + , TestTypeLib (Version [0,9] []) ] instance Text TestType where disp (TestTypeExe ver) = text "exitcode-stdio-" <> disp ver @@ -503,6 +515,125 @@ TestSuiteUnsupported testtype -> testtype -- --------------------------------------------------------------------------- +-- The Benchmark type + +-- | A \"benchmark\" stanza in a cabal file. +-- +data Benchmark = Benchmark { + benchmarkName :: String, + benchmarkInterface :: BenchmarkInterface, + benchmarkBuildInfo :: BuildInfo, + benchmarkEnabled :: Bool + -- TODO: See TODO for 'testEnabled'. + } + deriving (Show, Read, Eq) + +-- | The benchmark interfaces that are currently defined. Each +-- benchmark must specify which interface it supports. +-- +-- More interfaces may be defined in future, either new revisions or +-- totally new interfaces. +-- +data BenchmarkInterface = + + -- | Benchmark interface \"exitcode-stdio-1.0\". The benchmark + -- takes the form of an executable. It returns a zero exit code + -- for success, non-zero for failure. The stdout and stderr + -- channels may be logged. It takes no command line parameters + -- and nothing on stdin. + -- + BenchmarkExeV10 Version FilePath + + -- | A benchmark that does not conform to one of the above + -- interfaces for the given reason (e.g. unknown benchmark type). + -- + | BenchmarkUnsupported BenchmarkType + deriving (Eq, Read, Show) + +instance Monoid Benchmark where + mempty = Benchmark { + benchmarkName = mempty, + benchmarkInterface = mempty, + benchmarkBuildInfo = mempty, + benchmarkEnabled = False + } + + mappend a b = Benchmark { + benchmarkName = combine' benchmarkName, + benchmarkInterface = combine benchmarkInterface, + benchmarkBuildInfo = combine benchmarkBuildInfo, + benchmarkEnabled = if benchmarkEnabled a then True + else benchmarkEnabled b + } + where combine field = field a `mappend` field b + combine' f = case (f a, f b) of + ("", x) -> x + (x, "") -> x + (x, y) -> error "Ambiguous values for benchmark field: '" + ++ x ++ "' and '" ++ y ++ "'" + +instance Monoid BenchmarkInterface where + mempty = BenchmarkUnsupported (BenchmarkTypeUnknown mempty (Version [] [])) + mappend a (BenchmarkUnsupported _) = a + mappend _ b = b + +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) + +-- | The \"benchmark-type\" field in the benchmark stanza. +-- +data BenchmarkType = BenchmarkTypeExe Version + -- ^ \"type: exitcode-stdio-x.y\" + | BenchmarkTypeUnknown String Version + -- ^ Some unknown benchmark type e.g. \"type: foo\" + deriving (Show, Read, Eq) + +knownBenchmarkTypes :: [BenchmarkType] +knownBenchmarkTypes = [ BenchmarkTypeExe (Version [1,0] []) ] + +instance Text BenchmarkType where + disp (BenchmarkTypeExe ver) = text "exitcode-stdio-" <> disp ver + disp (BenchmarkTypeUnknown name ver) = text name <> char '-' <> disp ver + + parse = do + cs <- Parse.sepBy1 component (Parse.char '-') + _ <- Parse.char '-' + ver <- parse + let name = concat (intersperse "-" cs) + return $! case lowercase name of + "exitcode-stdio" -> BenchmarkTypeExe ver + _ -> BenchmarkTypeUnknown name ver + + where + component = do + cs <- Parse.munch1 Char.isAlphaNum + if all Char.isDigit cs then Parse.pfail else return cs + -- each component must contain an alphabetic character, to avoid + -- ambiguity in identifiers like foo-1 (the 1 is the version number). + +benchmarkType :: Benchmark -> BenchmarkType +benchmarkType benchmark = case benchmarkInterface benchmark of + BenchmarkExeV10 ver _ -> BenchmarkTypeExe ver + BenchmarkUnsupported benchmarktype -> benchmarktype + +-- --------------------------------------------------------------------------- -- The BuildInfo type -- Consider refactoring into executable and library versions. @@ -603,7 +734,8 @@ emptyBuildInfo = mempty -- | The 'BuildInfo' for the library (if there is one and it's buildable), and --- all buildable executables and test suites. Useful for gathering dependencies. +-- 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 @@ -615,6 +747,10 @@ , 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 @@ -813,7 +949,8 @@ 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) diff --git a/Distribution/PackageDescription/Check.hs b/Distribution/PackageDescription/Check.hs --- a/Distribution/PackageDescription/Check.hs +++ b/Distribution/PackageDescription/Check.hs @@ -204,23 +204,17 @@ PackageBuildImpossible "No executables and no library found. Nothing to do." - , check (not (null exeDuplicates)) $ - PackageBuildImpossible $ "Duplicate executable sections " - ++ commaSep exeDuplicates - , check (not (null testDuplicates)) $ - PackageBuildImpossible $ "Duplicate test sections " - ++ commaSep testDuplicates - - --TODO: this seems to duplicate a check on the testsuites - , check (not (null testsThatAreExes)) $ - PackageBuildImpossible $ "These test sections share names with executable sections: " - ++ commaSep testsThatAreExes + , check (not (null duplicateNames)) $ + PackageBuildImpossible $ "Duplicate sections: " ++ commaSep duplicateNames + ++ ". The name of every executable, test suite, and benchmark section in" + ++ " the package must be unique." ] --TODO: check for name clashes case insensitively: windows file systems cannot cope. ++ maybe [] checkLibrary (library pkg) ++ concatMap checkExecutable (executables pkg) ++ concatMap (checkTestSuite pkg) (testSuites pkg) + ++ concatMap (checkBenchmark pkg) (benchmarks pkg) ++ catMaybes [ @@ -233,9 +227,8 @@ where exeNames = map exeName $ executables pkg testNames = map testName $ testSuites pkg - exeDuplicates = dups exeNames - testDuplicates = dups testNames - testsThatAreExes = filter (flip elem exeNames) testNames + bmNames = map benchmarkName $ benchmarks pkg + duplicateNames = dups $ exeNames ++ testNames ++ bmNames checkLibrary :: Library -> [PackageCheck] checkLibrary lib = @@ -300,11 +293,9 @@ "The 'main-is' field must specify a '.hs' or '.lhs' file " ++ "(even if it is generated by a preprocessor)." - , check exeNameClash $ - PackageBuildImpossible $ - "The test suite " ++ testName test - ++ " has the same name as an executable." - + -- Test suites might be built as (internal) libraries named after + -- the test suite and thus their names must not clash with the + -- name of the package. , check libNameClash $ PackageBuildImpossible $ "The test suite " ++ testName test @@ -317,12 +308,57 @@ TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] _ -> False - exeNameClash = testName test `elem` [ exeName exe | exe <- executables pkg ] libNameClash = testName test `elem` [ libName | _lib <- maybeToList (library pkg) , let PackageName libName = pkgName (package pkg) ] +checkBenchmark :: PackageDescription -> Benchmark -> [PackageCheck] +checkBenchmark pkg bm = + catMaybes [ + + case benchmarkInterface bm of + BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) -> Just $ + PackageBuildWarning $ + quote (display tt) ++ " is not a known type of benchmark. " + ++ "The known benchmark types are: " + ++ commaSep (map display knownBenchmarkTypes) + + BenchmarkUnsupported tt -> Just $ + PackageBuildWarning $ + quote (display tt) ++ " is not a supported benchmark version. " + ++ "The known benchmark types are: " + ++ commaSep (map display knownBenchmarkTypes) + _ -> Nothing + + , check (not $ null moduleDuplicates) $ + PackageBuildWarning $ + "Duplicate modules in benchmark '" ++ benchmarkName bm ++ "': " + ++ commaSep (map display moduleDuplicates) + + , check mainIsWrongExt $ + PackageBuildImpossible $ + "The 'main-is' field must specify a '.hs' or '.lhs' file " + ++ "(even if it is generated by a preprocessor)." + + -- See comment for similar check on test suites. + , check libNameClash $ + PackageBuildImpossible $ + "The benchmark " ++ benchmarkName bm + ++ " has the same name as the package." + ] + where + moduleDuplicates = dups $ benchmarkModules bm + + mainIsWrongExt = case benchmarkInterface bm of + BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] + _ -> False + + libNameClash = benchmarkName bm `elem` [ libName + | _lib <- maybeToList (library pkg) + , let PackageName libName = + pkgName (package pkg) ] + -- ------------------------------------------------------------ -- * Additional pure checks -- ------------------------------------------------------------ @@ -827,7 +863,7 @@ PackageDistInexcusable $ "The 'test-suite' section is new in Cabal 1.10. " ++ "Unfortunately it messes up the parser in older Cabal versions " - ++ "so you must specify at least 'cabal-version: >= 1.8', but note" + ++ "so you must specify at least 'cabal-version: >= 1.8', but note " ++ "that only Cabal 1.10 and later can actually run such test suites." -- check use of default-language field diff --git a/Distribution/PackageDescription/Configuration.hs b/Distribution/PackageDescription/Configuration.hs --- a/Distribution/PackageDescription/Configuration.hs +++ b/Distribution/PackageDescription/Configuration.hs @@ -68,7 +68,8 @@ ( 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 @@ 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 @@ -- | 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 @@ -- 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 @@ 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 @@ -- ^ 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 @@ 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 @@ -- 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 @@ 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 @@ -607,6 +637,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 = diff --git a/Distribution/PackageDescription/Parse.hs b/Distribution/PackageDescription/Parse.hs --- a/Distribution/PackageDescription/Parse.hs +++ b/Distribution/PackageDescription/Parse.hs @@ -79,7 +79,7 @@ ( Text(disp, parse), display, simpleParse ) import Distribution.Compat.ReadP ((+++), option) -import Text.PrettyPrint.HughesPJ +import Text.PrettyPrint import Distribution.ParseUtils hiding (parseFields) import Distribution.PackageDescription @@ -305,6 +305,80 @@ -- --------------------------------------------------------------------------- +-- 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 @@ -- '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 @@ 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 @@ 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 @@ 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 @@ ++ "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 @@ (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 @@ }) 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 @@ "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'. -- @@ -903,6 +1026,12 @@ x <- lift $ parseFields testSuiteFieldDescrs storeXFieldsTest 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] -> diff --git a/Distribution/ParseUtils.hs b/Distribution/ParseUtils.hs --- a/Distribution/ParseUtils.hs +++ b/Distribution/ParseUtils.hs @@ -81,7 +81,7 @@ import Language.Haskell.Extension ( Language, Extension ) -import Text.PrettyPrint.HughesPJ hiding (braces) +import Text.PrettyPrint hiding (braces) import Data.Char (isSpace, toLower, isAlphaNum, isDigit) import Data.Maybe (fromMaybe) import Data.Tree as Tree (Tree(..), flatten) diff --git a/Distribution/Simple.hs b/Distribution/Simple.hs --- a/Distribution/Simple.hs +++ b/Distribution/Simple.hs @@ -112,6 +112,7 @@ , configure, checkForeignDeps ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) +import Distribution.Simple.Bench (bench) import Distribution.Simple.BuildPaths ( srcPref) import Distribution.Simple.Test (test) import Distribution.Simple.Install (install) @@ -206,6 +207,7 @@ ,registerCommand `commandAddAction` registerAction hooks ,unregisterCommand `commandAddAction` unregisterAction hooks ,testCommand `commandAddAction` testAction hooks + ,benchmarkCommand `commandAddAction` benchAction hooks ] -- | Combine the preprocessors in the given hooks with the @@ -360,6 +362,14 @@ (getBuildConfig hooks verbosity distPref) hooks flags' args +benchAction :: UserHooks -> BenchmarkFlags -> Args -> IO () +benchAction hooks flags args = do + let distPref = fromFlag $ benchmarkDistPref flags + verbosity = fromFlag $ benchmarkVerbosity flags + hookedActionWithArgs preBench benchHook postBench + (getBuildConfig hooks verbosity distPref) + hooks flags args + registerAction :: UserHooks -> RegisterFlags -> Args -> IO () registerAction hooks flags args = do let distPref = fromFlag $ regDistPref flags @@ -383,7 +393,17 @@ -> LocalBuildInfo -> IO ()) -> IO LocalBuildInfo -> UserHooks -> flags -> Args -> IO () -hookedAction pre_hook cmd_hook post_hook get_build_config hooks flags args = do +hookedAction pre_hook cmd_hook = + hookedActionWithArgs pre_hook (\h _ pd lbi uh flags -> cmd_hook h pd lbi uh flags) + +hookedActionWithArgs :: (UserHooks -> Args -> flags -> IO HookedBuildInfo) + -> (UserHooks -> Args -> PackageDescription -> LocalBuildInfo + -> UserHooks -> flags -> IO ()) + -> (UserHooks -> Args -> flags -> PackageDescription + -> LocalBuildInfo -> IO ()) + -> IO LocalBuildInfo + -> UserHooks -> flags -> Args -> IO () +hookedActionWithArgs pre_hook cmd_hook post_hook get_build_config hooks flags args = do pbi <- pre_hook hooks args flags localbuildinfo <- get_build_config let pkg_descr0 = localPkgDescr localbuildinfo @@ -392,7 +412,7 @@ let pkg_descr = updatePackageDescription pbi pkg_descr0 -- TODO: should we write the modified package descr back to the -- localbuildinfo? - cmd_hook hooks pkg_descr localbuildinfo hooks flags + cmd_hook hooks args pkg_descr localbuildinfo hooks flags post_hook hooks args flags pkg_descr localbuildinfo sanityCheckHookedBuildInfo :: PackageDescription -> HookedBuildInfo -> IO () @@ -499,6 +519,7 @@ buildHook = defaultBuildHook, copyHook = \desc lbi _ f -> install desc lbi f, -- has correct 'copy' behavior with params testHook = defaultTestHook, + benchHook = defaultBenchHook, instHook = defaultInstallHook, sDistHook = \p l h f -> sdist p l f srcPref (allSuffixHandlers h), cleanHook = \p _ _ f -> clean p f, @@ -644,6 +665,11 @@ -> UserHooks -> TestFlags -> IO () defaultTestHook pkg_descr localbuildinfo _ flags = test pkg_descr localbuildinfo flags + +defaultBenchHook :: Args -> PackageDescription -> LocalBuildInfo + -> UserHooks -> BenchmarkFlags -> IO () +defaultBenchHook args pkg_descr localbuildinfo _ flags = + bench args pkg_descr localbuildinfo flags defaultInstallHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO () diff --git a/Distribution/Simple/Bench.hs b/Distribution/Simple/Bench.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Bench.hs @@ -0,0 +1,156 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Bench +-- Copyright : Johan Tibell 2011 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point into running the benchmarks in a built +-- package. It performs the \"@.\/setup bench@\" action. It runs +-- benchmarks designated in the package description. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.Bench + ( bench + ) where + +import qualified Distribution.PackageDescription as PD + ( PackageDescription(..), BuildInfo(buildable) + , Benchmark(..), BenchmarkInterface(..), benchmarkType, hasBenchmarks ) +import Distribution.Simple.BuildPaths ( exeExtension ) +import Distribution.Simple.Compiler ( Compiler(..) ) +import Distribution.Simple.InstallDirs + ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..) + , substPathTemplate , toPathTemplate, PathTemplate ) +import qualified Distribution.Simple.LocalBuildInfo as LBI + ( LocalBuildInfo(..) ) +import Distribution.Simple.Setup ( BenchmarkFlags(..), fromFlag ) +import Distribution.Simple.UserHooks ( Args ) +import Distribution.Simple.Utils ( die, notice, rawSystemExitCode ) +import Distribution.Text + +import Control.Monad ( when, unless ) +import System.Exit ( ExitCode(..), exitFailure, exitWith ) +import System.Directory ( doesFileExist ) +import System.FilePath ( (), (<.>) ) + +-- | Perform the \"@.\/setup bench@\" action. +bench :: Args -- ^positional command-line arguments + -> PD.PackageDescription -- ^information from the .cabal file + -> LBI.LocalBuildInfo -- ^information from the configure step + -> BenchmarkFlags -- ^flags sent to benchmark + -> IO () +bench args pkg_descr lbi flags = do + let verbosity = fromFlag $ benchmarkVerbosity flags + benchmarkNames = args + pkgBenchmarks = PD.benchmarks pkg_descr + enabledBenchmarks = [ t | t <- pkgBenchmarks + , PD.benchmarkEnabled t + , PD.buildable (PD.benchmarkBuildInfo t) ] + + -- Run the benchmark + doBench :: PD.Benchmark -> IO ExitCode + doBench bm = + case PD.benchmarkInterface bm of + PD.BenchmarkExeV10 _ _ -> do + let cmd = LBI.buildDir lbi PD.benchmarkName bm + PD.benchmarkName bm <.> exeExtension + options = map (benchOption pkg_descr lbi bm) $ + benchmarkOptions flags + name = PD.benchmarkName bm + -- Check that the benchmark executable exists. + exists <- doesFileExist cmd + unless exists $ die $ + "Error: Could not find benchmark program \"" + ++ cmd ++ "\". Did you build the package first?" + + notice verbosity $ startMessage name + -- This will redirect the child process + -- stdout/stderr to the parent process. + exitcode <- rawSystemExitCode verbosity cmd options + notice verbosity $ finishMessage name exitcode + return exitcode + + _ -> do + notice verbosity $ "No support for running " + ++ "benchmark " ++ PD.benchmarkName bm ++ " of type: " + ++ show (disp $ PD.benchmarkType bm) + exitFailure + + when (not $ PD.hasBenchmarks pkg_descr) $ do + notice verbosity "Package has no benchmarks." + exitWith ExitSuccess + + when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $ + die $ "No benchmarks enabled. Did you remember to configure with " + ++ "\'--enable-benchmarks\'?" + + bmsToRun <- case benchmarkNames of + [] -> return enabledBenchmarks + names -> flip mapM names $ \bmName -> + let benchmarkMap = zip enabledNames enabledBenchmarks + enabledNames = map PD.benchmarkName enabledBenchmarks + allNames = map PD.benchmarkName pkgBenchmarks + in case lookup bmName benchmarkMap of + Just t -> return t + _ | bmName `elem` allNames -> + die $ "Package configured with benchmark " + ++ bmName ++ " disabled." + | otherwise -> die $ "no such benchmark: " ++ bmName + + let totalBenchmarks = length bmsToRun + notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..." + exitcodes <- mapM doBench bmsToRun + let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes) + unless allOk exitFailure + where + startMessage name = "Benchmark " ++ name ++ ": RUNNING...\n" + finishMessage name exitcode = "Benchmark " ++ name ++ ": " + ++ (case exitcode of + ExitSuccess -> "FINISH" + ExitFailure _ -> "ERROR") + + +-- TODO: This is abusing the notion of a 'PathTemplate'. The result +-- isn't neccesarily a path. +benchOption :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> PD.Benchmark + -> PathTemplate + -> String +benchOption pkg_descr lbi bm template = + fromPathTemplate $ substPathTemplate env template + where + env = initialPathTemplateEnv + (PD.package pkg_descr) (compilerId $ LBI.compiler lbi) ++ + [(BenchmarkNameVar, toPathTemplate $ PD.benchmarkName bm)] diff --git a/Distribution/Simple/Build.hs b/Distribution/Simple/Build.hs --- a/Distribution/Simple/Build.hs +++ b/Distribution/Simple/Build.hs @@ -64,12 +64,13 @@ import Distribution.Package ( Package(..), PackageName(..), PackageIdentifier(..) - , thisPackageVersion ) + , Dependency(..), thisPackageVersion ) import Distribution.Simple.Compiler ( CompilerFlavor(..), compilerFlavor, PackageDB(..) ) import Distribution.PackageDescription ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..) - , TestSuite(..), TestSuiteInterface(..) ) + , TestSuite(..), TestSuiteInterface(..), Benchmark(..) + , BenchmarkInterface(..) ) import qualified Distribution.InstalledPackageInfo as IPI import qualified Distribution.ModuleName as ModuleName @@ -78,11 +79,13 @@ import Distribution.Simple.PreProcess ( preprocessComponent, PPSuffixHandler ) import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(compiler, buildDir, withPackageDB) + ( LocalBuildInfo(compiler, buildDir, withPackageDB, withPrograms) , Component(..), ComponentLocalBuildInfo(..), withComponentsLBI , inplacePackageId ) +import Distribution.Simple.Program.Types +import Distribution.Simple.Program.Db import Distribution.Simple.BuildPaths - ( autogenModulesDir, autogenModuleName, cppHeaderName ) + ( autogenModulesDir, autogenModuleName, cppHeaderName, exeExtension ) import Distribution.Simple.Register ( registerPackage, inplaceInstalledPackageInfo ) import Distribution.Simple.Test ( stubFilePath, stubName ) @@ -97,6 +100,8 @@ import Data.Maybe ( maybeToList ) +import Data.List + ( intersect ) import Control.Monad ( unless ) import System.FilePath @@ -120,15 +125,16 @@ internalPackageDB <- createInternalPackageDB distPref - let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes - lbi' = lbi {withPackageDB = withPackageDB lbi ++ [internalPackageDB]} - -- Use the internal package DB for the exes. - withComponentsLBI pkg_descr lbi $ \comp clbi -> do - pre comp + let pre c lbi' = preprocessComponent pkg_descr c lbi' False verbosity suffixes + withComponentsLBI pkg_descr lbi $ \comp clbi -> case comp of CLib lib -> do + let bi = libBuildInfo lib + progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi) + lbi' = lbi { withPrograms = progs' } + pre comp lbi' info verbosity "Building library..." - buildLib verbosity pkg_descr lbi lib clbi + buildLib verbosity pkg_descr lbi' lib clbi -- Register the library in-place, so exes can depend -- on internally defined libraries. @@ -144,25 +150,40 @@ (withPackageDB lbi ++ [internalPackageDB]) CExe exe -> do + let bi = buildInfo exe + progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi) + lbi' = lbi { + withPrograms = progs', + withPackageDB = withPackageDB lbi ++ [internalPackageDB] + } + pre comp lbi' info verbosity $ "Building executable " ++ exeName exe ++ "..." buildExe verbosity pkg_descr lbi' exe clbi CTest test -> do case testInterface test of TestSuiteExeV10 _ f -> do - let exe = Executable + let bi = testBuildInfo test + exe = Executable { exeName = testName test , modulePath = f - , buildInfo = testBuildInfo test + , buildInfo = bi } + progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi) + lbi' = lbi { + withPrograms = progs', + withPackageDB = withPackageDB lbi ++ [internalPackageDB] + } + pre comp lbi' info verbosity $ "Building test suite " ++ testName test ++ "..." buildExe verbosity pkg_descr lbi' exe clbi TestSuiteLibV09 _ m -> do pwd <- getCurrentDirectory - let lib = Library + let bi = testBuildInfo test + lib = Library { exposedModules = [ m ] , libExposed = True - , libBuildInfo = testBuildInfo test + , libBuildInfo = bi } pkg = pkg_descr { package = (package pkg_descr) @@ -197,6 +218,13 @@ : (filter (\(_, x) -> let PackageName name = pkgName x in name == "Cabal" || name == "base") $ componentPackageDeps clbi) } + progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi) + lbi' = lbi { + withPrograms = progs', + withPackageDB = withPackageDB lbi ++ [internalPackageDB] + } + + pre comp lbi' info verbosity $ "Building test suite " ++ testName test ++ "..." buildLib verbosity pkg lbi' lib clbi registerPackage verbosity ipi pkg lbi' True $ withPackageDB lbi' @@ -204,6 +232,26 @@ TestSuiteUnsupported tt -> die $ "No support for building test suite " ++ "type " ++ display tt + CBench bm -> do + case benchmarkInterface bm of + BenchmarkExeV10 _ f -> do + let bi = benchmarkBuildInfo bm + exe = Executable + { exeName = benchmarkName bm + , modulePath = f + , buildInfo = bi + } + progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi) + lbi' = lbi { + withPrograms = progs', + withPackageDB = withPackageDB lbi ++ [internalPackageDB] + } + pre comp lbi' + info verbosity $ "Building benchmark " ++ benchmarkName bm ++ "..." + buildExe verbosity pkg_descr lbi' exe clbi + BenchmarkUnsupported tt -> die $ "No support for building benchmark " + ++ "type " ++ display tt + -- | Initialize a new package db file for libraries defined -- internally to the package. createInternalPackageDB :: FilePath -> IO PackageDB @@ -212,6 +260,22 @@ packageDB = SpecificPackageDB dbFile writeFile dbFile "[]" return packageDB + +addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo + -> ProgramDb -> ProgramDb +addInternalBuildTools pkg lbi bi progs = + foldr updateProgram progs internalBuildTools + where + internalBuildTools = + [ simpleConfiguredProgram toolName (FoundOnSystem toolLocation) + | toolName <- toolNames + , let toolLocation = buildDir lbi toolName toolName <.> exeExtension ] + toolNames = intersect buildToolNames internalExeNames + internalExeNames = map exeName (executables pkg) + buildToolNames = map buildToolName (buildTools bi) + where + buildToolName (Dependency (PackageName name) _ ) = name + -- TODO: build separate libs in separate dirs so that we can build -- multiple libs, e.g. for 'LibTest' library-style testsuites diff --git a/Distribution/Simple/Command.hs b/Distribution/Simple/Command.hs --- a/Distribution/Simple/Command.hs +++ b/Distribution/Simple/Command.hs @@ -94,7 +94,7 @@ import Distribution.ParseUtils import Distribution.ReadE import Distribution.Simple.Utils (die, intercalate) -import Text.PrettyPrint.HughesPJ ( punctuate, cat, comma, text, empty) +import Text.PrettyPrint ( punctuate, cat, comma, text, empty) data CommandUI flags = CommandUI { -- | The name of the command as it would be entered on the command line. diff --git a/Distribution/Simple/Configure.hs b/Distribution/Simple/Configure.hs --- a/Distribution/Simple/Configure.hs +++ b/Distribution/Simple/Configure.hs @@ -82,7 +82,7 @@ ( PackageDescription(..), specVersion, GenericPackageDescription(..) , Library(..), hasLibs, Executable(..), BuildInfo(..), allExtensions , HookedBuildInfo, updatePackageDescription, allBuildInfo - , FlagName(..), TestSuite(..) ) + , FlagName(..), TestSuite(..), Benchmark(..) ) import Distribution.PackageDescription.Configuration ( finalizePackageDescription, mapTreeData ) import Distribution.PackageDescription.Check @@ -91,7 +91,7 @@ import Distribution.Simple.Program ( Program(..), ProgramLocation(..), ConfiguredProgram(..) , ProgramConfiguration, defaultProgramConfiguration - , configureAllKnownPrograms, knownPrograms, lookupKnownProgram, addKnownProgram + , configureAllKnownPrograms, knownPrograms, lookupKnownProgram , userSpecifyArgss, userSpecifyPaths , requireProgram, requireProgramVersion , pkgConfigProgram, gccProgram, rawSystemProgramStdoutConf ) @@ -146,7 +146,7 @@ ( hPutStrLn, stderr, hClose ) import Distribution.Text ( Text(disp), display, simpleParse ) -import Text.PrettyPrint.HughesPJ +import Text.PrettyPrint ( comma, punctuate, render, nest, sep ) import Distribution.Compat.Exception ( catchExit, catchIO ) @@ -326,7 +326,11 @@ enableTest t = t { testEnabled = fromFlag (configTests cfg) } flaggedTests = map (\(n, t) -> (n, mapTreeData enableTest t)) (condTestSuites pkg_descr0) - pkg_descr0'' = pkg_descr0 { condTestSuites = flaggedTests } + enableBenchmark bm = bm { benchmarkEnabled = fromFlag (configBenchmarks cfg) } + flaggedBenchmarks = map (\(n, bm) -> (n, mapTreeData enableBenchmark bm)) + (condBenchmarks pkg_descr0) + pkg_descr0'' = pkg_descr0 { condTestSuites = flaggedTests + , condBenchmarks = flaggedBenchmarks } (pkg_descr0', flags) <- case finalizePackageDescription @@ -429,21 +433,26 @@ ++ "supported by " ++ display (compilerId comp) ++ ": " ++ intercalate ", " (map display exts) - -- configured known/required programs & build tools - let requiredBuildTools = concatMap buildTools (allBuildInfo pkg_descr) - - -- add all exes built by this package ("internal exes") to the program - -- conf; this makes the namespace of build-tools include intrapackage - -- references to executables - let programsConfig'' = foldr (addInternalExe buildDir') programsConfig' - (executables pkg_descr) + -- configured known/required programs & external build tools + -- exclude build-tool deps on "internal" exes in the same package + let requiredBuildTools = + [ buildTool + | let exeNames = map exeName (executables pkg_descr) + , bi <- allBuildInfo pkg_descr + , buildTool@(Dependency (PackageName toolName) reqVer) <- buildTools bi + , let isInternal = + toolName `elem` exeNames + -- we assume all internal build-tools are + -- versioned with the package: + && packageVersion pkg_descr `withinRange` reqVer + , not isInternal ] - programsConfig''' <- - configureAllKnownPrograms (lessVerbose verbosity) programsConfig'' + programsConfig'' <- + configureAllKnownPrograms (lessVerbose verbosity) programsConfig' >>= configureRequiredPrograms verbosity requiredBuildTools - (pkg_descr', programsConfig'''') <- - configurePkgconfigPackages verbosity pkg_descr programsConfig''' + (pkg_descr', programsConfig''') <- + configurePkgconfigPackages verbosity pkg_descr programsConfig'' split_objs <- if not (fromFlag $ configSplitObjs cfg) @@ -464,6 +473,8 @@ configExe exe = (exeName exe, configComponent (buildInfo exe)) configTest test = (testName test, configComponent(testBuildInfo test)) + configBenchmark bm = (benchmarkName bm, + configComponent(benchmarkBuildInfo bm)) configComponent bi = ComponentLocalBuildInfo { componentPackageDeps = if newPackageDepsBehaviour pkg_descr' @@ -485,7 +496,8 @@ mapMaybe exeDepToComp (buildTools bi) ++ mapMaybe libDepToComp (targetBuildDepends bi) where - bi = foldComponent libBuildInfo buildInfo testBuildInfo component + bi = foldComponent libBuildInfo buildInfo testBuildInfo + benchmarkBuildInfo component exeDepToComp (Dependency (PackageName name) _) = CExe `fmap` find ((==) name . exeName) (executables pkg_descr') @@ -498,13 +510,15 @@ where (g, lkup, _) = graphFromEdges $ allComponentsBy pkg_descr' $ \c -> (c, key c, map key (ipDeps c)) - key = foldComponent (const "library") exeName testName + key = foldComponent (const "library") exeName + testName benchmarkName -- check for cycles in the dependency graph buildOrder <- forM sccs $ \scc -> case scc of AcyclicSCC (c,_,_) -> return (foldComponent (const CLibName) (CExeName . exeName) (CTestName . testName) + (CBenchName . benchmarkName) c) CyclicSCC vs -> die $ "Found cycle in intrapackage dependency graph:\n " @@ -525,11 +539,12 @@ libraryConfig = configLib `fmap` library pkg_descr', executableConfigs = configExe `fmap` executables pkg_descr', testSuiteConfigs = configTest `fmap` testSuites pkg_descr', + benchmarkConfigs = configBenchmark `fmap` benchmarks pkg_descr', compBuildOrder = buildOrder, installedPkgs = packageDependsIndex, pkgDescrFile = Nothing, localPkgDescr = pkg_descr', - withPrograms = programsConfig'''', + withPrograms = programsConfig''', withVanillaLib = fromFlag $ configVanillaLib cfg, withProfLib = fromFlag $ configProfLib cfg, withSharedLib = fromFlag $ configSharedLib cfg, @@ -570,20 +585,11 @@ dirinfo "Documentation" (docdir dirs) (docdir relative) sequence_ [ reportProgram verbosity prog configuredProg - | (prog, configuredProg) <- knownPrograms programsConfig'''' ] + | (prog, configuredProg) <- knownPrograms programsConfig''' ] return lbi where - addInternalExe bd exe = - let nm = exeName exe in - addKnownProgram Program { - programName = nm, - programFindLocation = \_ -> return $ Just $ bd nm nm, - programFindVersion = \_ _ -> return Nothing, - programPostConf = \_ _ -> return [] - } - addExtraIncludeLibDirs pkg_descr = let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg , PD.includeDirs = configExtraIncludeDirs cfg} diff --git a/Distribution/Simple/GHC.hs b/Distribution/Simple/GHC.hs --- a/Distribution/Simple/GHC.hs +++ b/Distribution/Simple/GHC.hs @@ -585,6 +585,7 @@ ifSharedLib = when (withSharedLib lbi) ifGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi) comp = compiler lbi + ghcVersion = compilerVersion comp libBi <- hackThreadedFlag verbosity comp (withProfLib lbi) (libBuildInfo lib) @@ -645,15 +646,18 @@ stubObjs <- fmap catMaybes $ sequence [ findFileWithExtension [objExtension] [libTargetDir] (ModuleName.toFilePath x ++"_stub") - | x <- libModules lib ] + | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files + , x <- libModules lib ] stubProfObjs <- fmap catMaybes $ sequence [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] (ModuleName.toFilePath x ++"_stub") - | x <- libModules lib ] + | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files + , x <- libModules lib ] stubSharedObjs <- fmap catMaybes $ sequence [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] (ModuleName.toFilePath x ++"_stub") - | x <- libModules lib ] + | ghcVersion < Version [7,2] [] -- ghc-7.2+ does not make _stub.o files + , x <- libModules lib ] hObjs <- getHaskellObjects lib lbi pref objExtension True diff --git a/Distribution/Simple/GHC/IPI641.hs b/Distribution/Simple/GHC/IPI641.hs --- a/Distribution/Simple/GHC/IPI641.hs +++ b/Distribution/Simple/GHC/IPI641.hs @@ -110,7 +110,7 @@ Current.exposed = exposed ipi, Current.exposedModules = map convertModuleName (exposedModules ipi), Current.hiddenModules = map convertModuleName (hiddenModules ipi), - Current.trusted = False, + Current.trusted = Current.trusted Current.emptyInstalledPackageInfo, Current.importDirs = importDirs ipi, Current.libraryDirs = libraryDirs ipi, Current.hsLibraries = hsLibraries ipi, diff --git a/Distribution/Simple/GHC/IPI642.hs b/Distribution/Simple/GHC/IPI642.hs --- a/Distribution/Simple/GHC/IPI642.hs +++ b/Distribution/Simple/GHC/IPI642.hs @@ -145,7 +145,7 @@ Current.exposed = exposed ipi, Current.exposedModules = map convertModuleName (exposedModules ipi), Current.hiddenModules = map convertModuleName (hiddenModules ipi), - Current.trusted = False, + Current.trusted = Current.trusted Current.emptyInstalledPackageInfo, Current.importDirs = importDirs ipi, Current.libraryDirs = libraryDirs ipi, Current.hsLibraries = hsLibraries ipi, diff --git a/Distribution/Simple/Haddock.hs b/Distribution/Simple/Haddock.hs --- a/Distribution/Simple/Haddock.hs +++ b/Distribution/Simple/Haddock.hs @@ -71,7 +71,7 @@ ( defaultHscolourFlags, Flag(..), flagToMaybe, fromFlag , HaddockFlags(..), HscolourFlags(..) ) import Distribution.Simple.Build (initialBuildSteps) -import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplate, +import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplateEnv, PathTemplate, PathTemplateVariable(..), toPathTemplate, fromPathTemplate, substPathTemplate, @@ -122,6 +122,7 @@ argIgnoreExports :: Any, -- ^ ingore export lists in modules? argLinkSource :: Flag (Template,Template), -- ^ (template for modules, template for symbols) argCssFile :: Flag FilePath, -- ^ optinal custom css file. + argContents :: Flag String, -- ^ optional url to contents page argVerbose :: Any, argOutput :: Flag [Output], -- ^ Html or Hoogle doc or both? required. argInterfaces :: [(FilePath, Maybe FilePath)], -- ^ [(interface file, path to the html docs for links)] @@ -197,7 +198,7 @@ [ getInterfaces verbosity lbi (flagToMaybe (haddockHtmlLocation flags)) , getGhcLibDir verbosity lbi isVersion2 ] ++ map return - [ fromFlags flags + [ fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags , fromPackageDescription pkg_descr ] let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes @@ -265,8 +266,8 @@ -------------------------------------------------------------------------------------------------- -- constributions to HaddockArgs -fromFlags :: HaddockFlags -> HaddockArgs -fromFlags flags = +fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs +fromFlags env flags = mempty { argHideModules = (maybe mempty (All . not) $ flagToMaybe (haddockInternal flags), mempty), argLinkSource = if fromFlag (haddockHscolour flags) @@ -274,6 +275,7 @@ ,"src/%{MODULE/./-}.html#%{NAME}") else NoFlag, argCssFile = haddockCss flags, + argContents = fmap (fromPathTemplate . substPathTemplate env) (haddockContents flags), argVerbose = maybe mempty (Any . (>= deafening)) . flagToMaybe $ haddockVerbosity flags, argOutput = Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++ @@ -414,6 +416,7 @@ maybe [] (\(m,e) -> ["--source-module=" ++ m ,"--source-entity=" ++ e]) . flagToMaybe . argLinkSource $ args, maybe [] ((:[]).("--css="++)) . flagToMaybe . argCssFile $ args, + maybe [] ((:[]).("--use-contents="++)) . flagToMaybe . argContents $ args, bool [] [verbosityFlag] . getAny . argVerbose $ args, map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html") . fromFlag . argOutput $ args, renderInterfaces . argInterfaces $ args, @@ -442,8 +445,9 @@ let allPkgs = installedPkgs lbi directDeps = map fst (externalPackageDeps lbi) transitiveDeps <- case dependencyClosure allPkgs directDeps of - Left x -> return x - Right _ -> die "Can't find transitive deps for haddock" + Left x -> return x + Right inf -> die $ "internal error when calculating transative " + ++ "package dependencies.\nDebug info: " ++ show inf interfaces <- sequence [ case interfaceAndHtmlPath ipkg of Nothing -> return (Left (packageId ipkg)) @@ -473,9 +477,12 @@ return (interface, html) where expandTemplateVars = fromPathTemplate . substPathTemplate env - env = (PrefixVar, prefix (installDirTemplates lbi)) - : initialPathTemplateEnv (packageId pkg) (compilerId (compiler lbi)) + env = haddockTemplateEnv lbi (packageId pkg) +haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv +haddockTemplateEnv lbi pkg_id = (PrefixVar, prefix (installDirTemplates lbi)) + : initialPathTemplateEnv pkg_id (compilerId (compiler lbi)) + -- -------------------------------------------------------------------------- -- hscolour support @@ -595,6 +602,7 @@ argIgnoreExports = mempty, argLinkSource = mempty, argCssFile = mempty, + argContents = mempty, argVerbose = mempty, argOutput = mempty, argInterfaces = mempty, @@ -612,6 +620,7 @@ argIgnoreExports = mult argIgnoreExports, argLinkSource = mult argLinkSource, argCssFile = mult argCssFile, + argContents = mult argContents, argVerbose = mult argVerbose, argOutput = mult argOutput, argInterfaces = mult argInterfaces, diff --git a/Distribution/Simple/Hpc.hs b/Distribution/Simple/Hpc.hs --- a/Distribution/Simple/Hpc.hs +++ b/Distribution/Simple/Hpc.hs @@ -41,16 +41,15 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} module Distribution.Simple.Hpc - ( hpcDir - , enableCoverage + ( enableCoverage + , htmlDir , tixDir , tixFilePath - , doHpcMarkup - , findTixFiles + , markupPackage + , markupTest ) where -import Control.Exception ( bracket ) -import Control.Monad ( unless, when ) +import Control.Monad ( when ) import Distribution.Compiler ( CompilerFlavor(..) ) import Distribution.ModuleName ( main ) import Distribution.PackageDescription @@ -60,14 +59,14 @@ , TestSuite(..) , testModules ) -import Distribution.Simple.Utils ( die, notice ) +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) +import Distribution.Simple.Program ( hpcProgram, requireProgram ) +import Distribution.Simple.Program.Hpc ( markup, union ) +import Distribution.Simple.Utils ( notice ) import Distribution.Text import Distribution.Verbosity ( Verbosity() ) -import System.Directory ( doesFileExist, getDirectoryContents, removeFile ) -import System.Exit ( ExitCode(..) ) +import System.Directory ( createDirectoryIfMissing, doesFileExist ) import System.FilePath -import System.IO ( hClose, IOMode(..), openFile, openTempFile ) -import System.Process ( runProcess, waitForProcess ) -- ------------------------------------------------------------------------- -- Haskell Program Coverage @@ -95,7 +94,7 @@ Just xs -> (GHC, hpcOpts ++ xs) _ -> (GHC, hpcOpts) newOptions = (:) newGHCOpts $ filter ((== GHC) . fst) oldOptions - hpcOpts = ["-fhpc", "-hpcdir", hpcDir distPref name] + hpcOpts = ["-fhpc", "-hpcdir", mixDir distPref name] in oldBI { options = newOptions } enableLibCoverage l = l { libBuildInfo = enableBICoverage (display $ package p) @@ -105,81 +104,67 @@ t { testBuildInfo = enableBICoverage (testName t) (testBuildInfo t) } hpcDir :: FilePath -- ^ \"dist/\" prefix - -> FilePath -- ^ Component subdirectory name -> FilePath -- ^ Directory containing component's HPC .mix files -hpcDir distPref name = distPref "hpc" name +hpcDir distPref = distPref "hpc" +mixDir :: FilePath -- ^ \"dist/\" prefix + -> FilePath -- ^ Component name + -> FilePath -- ^ Directory containing test suite's .mix files +mixDir distPref name = hpcDir distPref "mix" name + tixDir :: FilePath -- ^ \"dist/\" prefix - -> TestSuite -- ^ Test suite + -> FilePath -- ^ Component name -> FilePath -- ^ Directory containing test suite's .tix files -tixDir distPref suite = distPref "test" testName suite +tixDir distPref name = hpcDir distPref "tix" name -- | Path to the .tix file containing a test suite's sum statistics. tixFilePath :: FilePath -- ^ \"dist/\" prefix - -> TestSuite -- ^ Test suite - -> FilePath -- Path to test suite's .tix file -tixFilePath distPref suite = tixDir distPref suite testName suite <.> "tix" + -> FilePath -- ^ Component name + -> FilePath -- ^ Path to test suite's .tix file +tixFilePath distPref name = tixDir distPref name name <.> "tix" --- | Returns a list of all the .tix files in a test suite's .tix file --- directory. Returned paths are the complete relative path to each file. -findTixFiles :: FilePath -- ^ \"dist/\" prefix - -> TestSuite -- ^ Test suite - -> IO [FilePath] -- ^ All .tix files belonging to test suite -findTixFiles distPref suite = do - files <- getDirectoryContents $ tixDir distPref suite - let tixFiles = flip filter files $ \x -> takeExtension x == ".tix" - return $ map (tixDir distPref suite ) tixFiles +htmlDir :: FilePath -- ^ \"dist/\" prefix + -> FilePath -- ^ Component name + -> FilePath -- ^ Path to test suite's HTML markup directory +htmlDir distPref name = hpcDir distPref "html" name -- | Generate the HTML markup for a test suite. -doHpcMarkup :: Verbosity - -> FilePath -- ^ \"dist/\" prefix - -> String -- ^ Library name - -> TestSuite - -> IO () -doHpcMarkup verbosity distPref libName suite = do - tixFiles <- findTixFiles distPref suite - when (not $ null tixFiles) $ do - let hpcOptions = map (\x -> "--exclude=" ++ display x) excluded - unionOptions = [ "sum" - , "--union" - , "--output=" ++ tixFilePath distPref suite - ] - ++ hpcOptions ++ tixFiles - markupOptions = [ "markup" - , tixFilePath distPref suite - , "--hpcdir=" ++ hpcDir distPref libName - , "--destdir=" ++ tixDir distPref suite - ] - ++ hpcOptions - excluded = testModules suite ++ [ main ] - --TODO: use standard process utilities from D.S.Utils - runHpc opts h = runProcess "hpc" opts Nothing Nothing Nothing - (Just h) (Just h) - bracket (openHpcTemp $ tixDir distPref suite) deleteIfExists - $ \hpcOut -> do - hUnion <- openFile hpcOut AppendMode - procUnion <- runHpc unionOptions hUnion - exitUnion <- waitForProcess procUnion - success <- case exitUnion of - ExitSuccess -> do - hMarkup <- openFile hpcOut AppendMode - procMarkup <- runHpc markupOptions hMarkup - exitMarkup <- waitForProcess procMarkup - case exitMarkup of - ExitSuccess -> return True - _ -> return False - _ -> return False - unless success $ do - errs <- readFile hpcOut - die $ "HPC failed:\n" ++ errs - when success $ notice verbosity - $ "Test coverage report written to " - ++ tixDir distPref suite "hpc_index" - <.> "html" - return () - where openHpcTemp dir = do - (f, h) <- openTempFile dir $ "cabal-test-hpc-" <.> "log" - hClose h >> return f - deleteIfExists path = do - exists <- doesFileExist path - when exists $ removeFile path +markupTest :: Verbosity + -> LocalBuildInfo + -> FilePath -- ^ \"dist/\" prefix + -> String -- ^ Library name + -> TestSuite + -> IO () +markupTest verbosity lbi distPref libName suite = do + tixFileExists <- doesFileExist $ tixFilePath distPref $ testName suite + when tixFileExists $ do + (hpc, _) <- requireProgram verbosity hpcProgram $ withPrograms lbi + markup hpc verbosity (tixFilePath distPref $ testName suite) + (mixDir distPref libName) + (htmlDir distPref $ testName suite) + (testModules suite ++ [ main ]) + notice verbosity $ "Test coverage report written to " + ++ htmlDir distPref (testName suite) + "hpc_index" <.> "html" + +-- | Generate the HTML markup for all of a package's test suites. +markupPackage :: Verbosity + -> LocalBuildInfo + -> FilePath -- ^ \"dist/\" prefix + -> String -- ^ Library name + -> [TestSuite] + -> IO () +markupPackage verbosity lbi distPref libName suites = do + let tixFiles = map (tixFilePath distPref . testName) suites + tixFilesExist <- mapM doesFileExist tixFiles + when (and tixFilesExist) $ do + (hpc, _) <- requireProgram verbosity hpcProgram $ withPrograms lbi + let outFile = tixFilePath distPref libName + mixDir' = mixDir distPref libName + htmlDir' = htmlDir distPref libName + excluded = concatMap testModules suites ++ [ main ] + createDirectoryIfMissing True $ takeDirectory outFile + union hpc verbosity tixFiles outFile excluded + markup hpc verbosity outFile mixDir' htmlDir' excluded + notice verbosity $ "Package coverage report written to " + ++ htmlDir' "hpc_index.html" diff --git a/Distribution/Simple/InstallDirs.hs b/Distribution/Simple/InstallDirs.hs --- a/Distribution/Simple/InstallDirs.hs +++ b/Distribution/Simple/InstallDirs.hs @@ -60,6 +60,7 @@ PathTemplate, PathTemplateVariable(..), + PathTemplateEnv, toPathTemplate, fromPathTemplate, substPathTemplate, @@ -390,6 +391,7 @@ | ExecutableNameVar -- ^ The executable name; used in shell wrappers | TestSuiteNameVar -- ^ The name of the test suite being run | TestSuiteResultVar -- ^ The result of the test suite being run, eg @pass@, @fail@, or @error@. + | BenchmarkNameVar -- ^ The name of the benchmark being run deriving Eq type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)] @@ -484,6 +486,7 @@ show ExecutableNameVar = "executablename" show TestSuiteNameVar = "test-suite" show TestSuiteResultVar = "result" + show BenchmarkNameVar = "benchmark" instance Read PathTemplateVariable where readsPrec _ s = @@ -507,7 +510,8 @@ ,("arch", ArchVar) ,("executablename", ExecutableNameVar) ,("test-suite", TestSuiteNameVar) - ,("result", TestSuiteResultVar)] + ,("result", TestSuiteResultVar) + ,("benchmark", BenchmarkNameVar)] instance Show PathComponent where show (Ordinary path) = path diff --git a/Distribution/Simple/LocalBuildInfo.hs b/Distribution/Simple/LocalBuildInfo.hs --- a/Distribution/Simple/LocalBuildInfo.hs +++ b/Distribution/Simple/LocalBuildInfo.hs @@ -75,7 +75,7 @@ import Distribution.PackageDescription ( PackageDescription(..), withLib, Library(libBuildInfo), withExe , Executable(exeName, buildInfo), withTest, TestSuite(..) - , BuildInfo(buildable) ) + , BuildInfo(buildable), Benchmark(..) ) import Distribution.Package ( PackageId, Package(..), InstalledPackageId(..) ) import Distribution.Simple.Compiler @@ -117,6 +117,7 @@ -- ^ All the components to build, ordered by topological sort -- over the intrapackage dependency graph testSuiteConfigs :: [(String, ComponentLocalBuildInfo)], + benchmarkConfigs :: [(String, ComponentLocalBuildInfo)], installedPkgs :: PackageIndex, -- ^ All the info about the installed packages that the -- current package depends on (directly or indirectly). @@ -140,13 +141,17 @@ progSuffix :: PathTemplate -- ^Suffix to be appended to installed executables } deriving (Read, Show) --- | External package dependencies for the package as a whole, the union of the --- individual 'targetPackageDeps'. +-- | External package dependencies for the package as a whole. This is the +-- union of the individual 'componentPackageDeps', less any internal deps. externalPackageDeps :: LocalBuildInfo -> [(InstalledPackageId, PackageId)] -externalPackageDeps lbi = nub $ +externalPackageDeps lbi = filter (not . internal . snd) $ nub $ -- TODO: what about non-buildable components? - maybe [] componentPackageDeps (libraryConfig lbi) - ++ concatMap (componentPackageDeps . snd) (executableConfigs lbi) + maybe [] componentPackageDeps (libraryConfig lbi) + ++ concatMap (componentPackageDeps . snd) (executableConfigs lbi) + where + -- True if this dependency is an internal one (depends on the library + -- defined in the same package). + internal pkgid = pkgid == packageId (localPkgDescr lbi) -- | The installed package Id we use for local packages registered in the local -- package db. This is what is used for intra-package deps between components. @@ -157,14 +162,16 @@ -- ----------------------------------------------------------------------------- -- Buildable components -data Component = CLib Library - | CExe Executable - | CTest TestSuite +data Component = CLib Library + | CExe Executable + | CTest TestSuite + | CBench Benchmark deriving (Show, Eq, Read) -data ComponentName = CLibName -- currently only a single lib - | CExeName String - | CTestName String +data ComponentName = CLibName -- currently only a single lib + | CExeName String + | CTestName String + | CBenchName String deriving (Show, Eq, Read) data ComponentLocalBuildInfo = ComponentLocalBuildInfo { @@ -179,11 +186,13 @@ foldComponent :: (Library -> a) -> (Executable -> a) -> (TestSuite -> a) + -> (Benchmark -> a) -> Component -> a -foldComponent f _ _ (CLib lib) = f lib -foldComponent _ f _ (CExe exe) = f exe -foldComponent _ _ f (CTest tst) = f tst +foldComponent f _ _ _ (CLib lib) = f lib +foldComponent _ f _ _ (CExe exe) = f exe +foldComponent _ _ f _ (CTest tst) = f tst +foldComponent _ _ _ f (CBench bch) = f bch -- | Obtains all components (libs, exes, or test suites), transformed by the -- given function. Useful for gathering dependencies with component context. @@ -198,6 +207,9 @@ ++ [ f (CTest tst) | tst <- testSuites pkg_descr , buildable (testBuildInfo tst) , testEnabled tst ] + ++ [ f (CBench bm) | bm <- benchmarks pkg_descr + , buildable (benchmarkBuildInfo bm) + , benchmarkEnabled bm ] -- |If the package description has a library section, call the given -- function with the library build info as argument. Extended version of @@ -264,14 +276,26 @@ missingtest = "internal error: component list includes a test suite " ++ name ++ " but the package contains no such test suite." + compF (CBenchName name) = + case find (\bch -> benchmarkName bch == name) (benchmarks pkg_descr) of + Nothing -> die missingbench + Just bch -> case lookup name (benchmarkConfigs lbi) of + Nothing -> die (missingBenchConf name) + Just clbi -> f (CBench bch) clbi + where + missingbench = "internal error: component list includes a benchmark " + ++ name ++ " but the package contains no such benchmark." + missingLibConf :: String -missingExeConf, missingTestConf :: String -> String +missingExeConf, missingTestConf, missingBenchConf :: String -> String missingLibConf = "internal error: the package contains a library " ++ "but there is no corresponding configuration data" missingExeConf name = "internal error: the package contains an executable " ++ name ++ " but there is no corresponding configuration data" missingTestConf name = "internal error: the package contains a test suite " + ++ name ++ " but there is no corresponding configuration data" +missingBenchConf name = "internal error: the package contains a benchmark " ++ name ++ " but there is no corresponding configuration data" diff --git a/Distribution/Simple/PreProcess.hs b/Distribution/Simple/PreProcess.hs --- a/Distribution/Simple/PreProcess.hs +++ b/Distribution/Simple/PreProcess.hs @@ -66,7 +66,8 @@ , Executable(..) , Library(..), libModules , TestSuite(..), testModules - , TestSuiteInterface(..) ) + , TestSuiteInterface(..) + , Benchmark(..), benchmarkModules, BenchmarkInterface(..) ) import qualified Distribution.InstalledPackageInfo as Installed ( InstalledPackageInfo_(..) ) import qualified Distribution.Simple.PackageIndex as PackageIndex @@ -209,6 +210,14 @@ preProcessTest test (stubFilePath test) testDir TestSuiteUnsupported tt -> die $ "No support for preprocessing test " ++ "suite type " ++ display tt + CBench bm@Benchmark{ benchmarkName = nm } -> do + setupMessage verbosity ("Preprocessing benchmark '" ++ nm ++ "' for") (packageId pd) + case benchmarkInterface bm of + BenchmarkExeV10 _ f -> + preProcessBench bm f $ buildDir lbi benchmarkName bm + benchmarkName bm ++ "-tmp" + BenchmarkUnsupported tt -> die $ "No support for preprocessing benchmark " + ++ "type " ++ display tt where builtinSuffixes | NHC == compilerFlavor (compiler lbi) = ["hs", "lhs", "gc"] @@ -216,15 +225,18 @@ localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers] pre dirs dir lhndlrs fp = preprocessFile dirs dir isSrcDist fp verbosity builtinSuffixes lhndlrs - preProcessTest test exePath testDir = do - let bi = testBuildInfo test - biHandlers = localHandlers bi + preProcessTest test = preProcessComponent (testBuildInfo test) + (testModules test) + preProcessBench bm = preProcessComponent (benchmarkBuildInfo bm) + (benchmarkModules bm) + preProcessComponent bi modules exePath dir = do + let biHandlers = localHandlers bi sourceDirs = hsSourceDirs bi ++ [ autogenModulesDir lbi ] sequence_ [ preprocessFile sourceDirs (buildDir lbi) isSrcDist (ModuleName.toFilePath modu) verbosity builtinSuffixes biHandlers - | modu <- testModules test ] - preprocessFile (testDir : (hsSourceDirs bi)) testDir isSrcDist + | modu <- modules ] + preprocessFile (dir : (hsSourceDirs bi)) dir isSrcDist (dropExtensions $ exePath) verbosity builtinSuffixes biHandlers diff --git a/Distribution/Simple/Program.hs b/Distribution/Simple/Program.hs --- a/Distribution/Simple/Program.hs +++ b/Distribution/Simple/Program.hs @@ -110,6 +110,7 @@ , tarProgram , cppProgram , pkgConfigProgram + , hpcProgram -- * deprecated , rawSystemProgram diff --git a/Distribution/Simple/Program/Builtin.hs b/Distribution/Simple/Program/Builtin.hs --- a/Distribution/Simple/Program/Builtin.hs +++ b/Distribution/Simple/Program/Builtin.hs @@ -42,6 +42,7 @@ tarProgram, cppProgram, pkgConfigProgram, + hpcProgram, ) where import Distribution.Simple.Program.Types @@ -69,6 +70,7 @@ , lhcProgram , lhcPkgProgram , uhcProgram + , hpcProgram -- preprocessors , hscolourProgram , haddockProgram @@ -155,6 +157,14 @@ programFindVersion = findProgramVersion "--version-dotted" id } +hpcProgram :: Program +hpcProgram = (simpleProgram "hpc") + { + programFindVersion = findProgramVersion "version" $ \str -> + case words str of + (_ : _ : _ : ver : _) -> ver + _ -> "" + } -- AArgh! Finding the version of hugs or ffihugs is almost impossible. hugsProgram :: Program diff --git a/Distribution/Simple/Program/Hpc.hs b/Distribution/Simple/Program/Hpc.hs new file mode 100644 --- /dev/null +++ b/Distribution/Simple/Program/Hpc.hs @@ -0,0 +1,73 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Hpc +-- Copyright : Thomas Tuegel 2011 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @hpc@ program. + +module Distribution.Simple.Program.Hpc + ( markup + , union + ) where + +import Distribution.ModuleName ( ModuleName ) +import Distribution.Simple.Program.Run + ( ProgramInvocation, programInvocation, runProgramInvocation ) +import Distribution.Simple.Program.Types ( ConfiguredProgram ) +import Distribution.Text ( display ) +import Distribution.Verbosity ( Verbosity ) + +markup :: ConfiguredProgram + -> Verbosity + -> FilePath -- ^ Path to .tix file + -> FilePath -- ^ Path to directory with .mix files + -> FilePath -- ^ Path where html output should be located + -> [ModuleName] -- ^ List of modules to exclude from report + -> IO () +markup hpc verbosity tixFile hpcDir destDir excluded = + runProgramInvocation verbosity + (markupInvocation hpc tixFile hpcDir destDir excluded) + +markupInvocation :: ConfiguredProgram + -> FilePath -- ^ Path to .tix file + -> FilePath -- ^ Path to directory with .mix files + -> FilePath -- ^ Path where html output should be + -- located + -> [ModuleName] -- ^ List of modules to exclude from + -- report + -> ProgramInvocation +markupInvocation hpc tixFile hpcDir destDir excluded = + let args = [ "markup", tixFile + , "--hpcdir=" ++ hpcDir + , "--destdir=" ++ destDir + ] + ++ ["--exclude=" ++ display moduleName + | moduleName <- excluded ] + in programInvocation hpc args + +union :: ConfiguredProgram + -> Verbosity + -> [FilePath] -- ^ Paths to .tix files + -> FilePath -- ^ Path to resultant .tix file + -> [ModuleName] -- ^ List of modules to exclude from union + -> IO () +union hpc verbosity tixFiles outFile excluded = + runProgramInvocation verbosity + (unionInvocation hpc tixFiles outFile excluded) + +unionInvocation :: ConfiguredProgram + -> [FilePath] -- ^ Paths to .tix files + -> FilePath -- ^ Path to resultant .tix file + -> [ModuleName] -- ^ List of modules to exclude from union + -> ProgramInvocation +unionInvocation hpc tixFiles outFile excluded = + programInvocation hpc $ concat + [ ["sum", "--union"] + , tixFiles + , ["--output=" ++ outFile] + , ["--exclude=" ++ display moduleName + | moduleName <- excluded ] + ] diff --git a/Distribution/Simple/Program/Types.hs b/Distribution/Simple/Program/Types.hs --- a/Distribution/Simple/Program/Types.hs +++ b/Distribution/Simple/Program/Types.hs @@ -17,7 +17,6 @@ module Distribution.Simple.Program.Types ( -- * Program and functions for constructing them Program(..), - internalProgram, simpleProgram, -- * Configured program and related functions @@ -25,19 +24,21 @@ programPath, ProgArg, ProgramLocation(..), + simpleConfiguredProgram, ) where -import Data.List (nub) -import System.FilePath (()) - import Distribution.Simple.Utils - ( findProgramLocation, findFirstFile ) + ( findProgramLocation ) import Distribution.Version ( Version ) import Distribution.Verbosity ( Verbosity ) -- | Represents a program which can be configured. +-- +-- Note: rather than constructing this directly, start with 'simpleProgram' and +-- override any extra fields. +-- data Program = Program { -- | The simple name of the program, eg. ghc programName :: String, @@ -59,6 +60,12 @@ type ProgArg = String +-- | Represents a program which has been configured and is thus ready to be run. +-- +-- These are usually made by configuring a 'Program', but if you have to +-- construct one directly then start with 'simpleConfiguredProgram' and +-- override any extra fields. +-- data ConfiguredProgram = ConfiguredProgram { -- | Just the name again programId :: String, @@ -87,7 +94,7 @@ -- ^The user gave the path to this program, -- eg. --ghc-path=\/usr\/bin\/ghc-6.6 | FoundOnSystem { locationPath :: FilePath } - -- ^The location of the program, as located by searching PATH. + -- ^The program was found automatically. deriving (Read, Show, Eq) -- | The full path of a configured program. @@ -109,14 +116,15 @@ programPostConf = \_ _ -> return [] } --- | Make a simple 'internal' program; that is, one that was built as an --- executable already and is expected to be found in the build directory -internalProgram :: [FilePath] -> String -> Program -internalProgram paths name = Program { - programName = name, - programFindLocation = \_v -> - findFirstFile id [ path name | path <- nub paths ], - programFindVersion = \_ _ -> return Nothing, - programPostConf = \_ _ -> return [] +-- | Make a simple 'ConfiguredProgram'. +-- +-- > simpleConfiguredProgram "foo" (FoundOnSystem path) +-- +simpleConfiguredProgram :: String -> ProgramLocation -> ConfiguredProgram +simpleConfiguredProgram name loc = ConfiguredProgram { + programId = name, + programVersion = Nothing, + programDefaultArgs = [], + programOverrideArgs = [], + programLocation = loc } - diff --git a/Distribution/Simple/Register.hs b/Distribution/Simple/Register.hs --- a/Distribution/Simple/Register.hs +++ b/Distribution/Simple/Register.hs @@ -275,7 +275,7 @@ IPI.exposed = libExposed lib, IPI.exposedModules = exposedModules lib, IPI.hiddenModules = otherModules bi, - IPI.trusted = False, + IPI.trusted = IPI.trusted IPI.emptyInstalledPackageInfo, IPI.importDirs = [ libdir installDirs | hasModules ], IPI.libraryDirs = if hasLibrary then libdir installDirs : extraLibDirs bi diff --git a/Distribution/Simple/Setup.hs b/Distribution/Simple/Setup.hs --- a/Distribution/Simple/Setup.hs +++ b/Distribution/Simple/Setup.hs @@ -72,6 +72,7 @@ SDistFlags(..), emptySDistFlags, defaultSDistFlags, sdistCommand, TestFlags(..), emptyTestFlags, defaultTestFlags, testCommand, TestShowDetails(..), + BenchmarkFlags(..), emptyBenchmarkFlags, defaultBenchmarkFlags, benchmarkCommand, CopyDest(..), configureArgs, configureOptions, configureCCompiler, configureLinker, installDirsOptions, @@ -292,6 +293,7 @@ -- dependencies configConfigurationsFlags :: FlagAssignment, configTests :: Flag Bool, -- ^Enable test suite compilation + configBenchmarks :: Flag Bool, -- ^Enable benchmark compilation configLibCoverage :: Flag Bool -- ^ Enable test suite program coverage } deriving (Read,Show) @@ -315,6 +317,7 @@ configSplitObjs = Flag False, -- takes longer, so turn off by default configStripExes = Flag True, configTests = Flag False, + configBenchmarks = Flag False, configLibCoverage = Flag False } @@ -478,6 +481,10 @@ "build library and test suites with Haskell Program Coverage enabled. (GHC only)" configLibCoverage (\v flags -> flags { configLibCoverage = v }) (boolOpt [] []) + ,option "" ["benchmarks"] + "dependency checking and compilation for benchmarks listed in the package description file." + configBenchmarks (\v flags -> flags { configBenchmarks = v }) + (boolOpt [] []) ] where readFlagList :: String -> FlagAssignment @@ -587,7 +594,8 @@ configExtraIncludeDirs = mempty, configConfigurationsFlags = mempty, configTests = mempty, - configLibCoverage = mempty + configLibCoverage = mempty, + configBenchmarks = mempty } mappend a b = ConfigFlags { configPrograms = configPrograms b, @@ -619,7 +627,8 @@ configExtraIncludeDirs = combine configExtraIncludeDirs, configConfigurationsFlags = combine configConfigurationsFlags, configTests = combine configTests, - configLibCoverage = combine configLibCoverage + configLibCoverage = combine configLibCoverage, + configBenchmarks = combine configBenchmarks } where combine field = field a `mappend` field b @@ -1002,6 +1011,7 @@ haddockCss :: Flag FilePath, haddockHscolour :: Flag Bool, haddockHscolourCss :: Flag FilePath, + haddockContents :: Flag PathTemplate, haddockDistPref :: Flag FilePath, haddockVerbosity :: Flag Verbosity } @@ -1019,6 +1029,7 @@ haddockCss = NoFlag, haddockHscolour = Flag False, haddockHscolourCss = NoFlag, + haddockContents = NoFlag, haddockDistPref = Flag defaultDistPref, haddockVerbosity = Flag normal } @@ -1074,6 +1085,13 @@ "Use PATH as the HsColour stylesheet" haddockHscolourCss (\v flags -> flags { haddockHscolourCss = v }) (reqArgFlag "PATH") + + ,option "" ["contents-location"] + "Bake URL in as the location for the contents page" + haddockContents (\v flags -> flags { haddockContents = v }) + (reqArg' "URL" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate)) ] ++ programConfigurationPaths progConf ParseArgs haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v}) @@ -1098,6 +1116,7 @@ haddockCss = mempty, haddockHscolour = mempty, haddockHscolourCss = mempty, + haddockContents = mempty, haddockDistPref = mempty, haddockVerbosity = mempty } @@ -1112,6 +1131,7 @@ haddockCss = combine haddockCss, haddockHscolour = combine haddockHscolour, haddockHscolourCss = combine haddockHscolourCss, + haddockContents = combine haddockContents, haddockDistPref = combine haddockDistPref, haddockVerbosity = combine haddockVerbosity } @@ -1265,7 +1285,7 @@ --TODO: eliminate the test list and pass it directly as positional args to the testHook testList :: Flag [String], -- TODO: think about if/how options are passed to test exes - testOptions :: Flag [PathTemplate] + testOptions :: [PathTemplate] } defaultTestFlags :: TestFlags @@ -1277,7 +1297,7 @@ testShowDetails = toFlag Failures, testKeepTix = toFlag False, testList = Flag [], - testOptions = Flag [] + testOptions = [] } testCommand :: CommandUI TestFlags @@ -1325,16 +1345,16 @@ ++ "(name templates can use $pkgid, $compiler, " ++ "$os, $arch, $test-suite)") testOptions (\v flags -> flags { testOptions = v }) - (reqArg' "TEMPLATES" (toFlag . map toPathTemplate . splitArgs) - (map fromPathTemplate . fromFlagOrDefault [])) + (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs) + (const [])) , option [] ["test-option"] ("give extra option to test executables " ++ "(no need to quote options containing spaces, " ++ "name template can use $pkgid, $compiler, " ++ "$os, $arch, $test-suite)") testOptions (\v flags -> flags { testOptions = v }) - (reqArg' "TEMPLATE" (\x -> toFlag [toPathTemplate x]) - (map fromPathTemplate . fromFlagOrDefault [])) + (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) + (map fromPathTemplate)) ] emptyTestFlags :: TestFlags @@ -1360,6 +1380,67 @@ testKeepTix = combine testKeepTix, testList = combine testList, testOptions = combine testOptions + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Benchmark flags +-- ------------------------------------------------------------ + +data BenchmarkFlags = BenchmarkFlags { + benchmarkDistPref :: Flag FilePath, + benchmarkVerbosity :: Flag Verbosity, + benchmarkOptions :: [PathTemplate] + } + +defaultBenchmarkFlags :: BenchmarkFlags +defaultBenchmarkFlags = BenchmarkFlags { + benchmarkDistPref = Flag defaultDistPref, + benchmarkVerbosity = Flag normal, + benchmarkOptions = [] + } + +benchmarkCommand :: CommandUI BenchmarkFlags +benchmarkCommand = makeCommand name shortDesc longDesc defaultBenchmarkFlags options + where + name = "bench" + shortDesc = "Run the benchmark, if any (configure with UserHooks)." + longDesc = Nothing + options showOrParseArgs = + [ optionVerbosity benchmarkVerbosity (\v flags -> flags { benchmarkVerbosity = v }) + , optionDistPref + benchmarkDistPref (\d flags -> flags { benchmarkDistPref = d }) + showOrParseArgs + , option [] ["benchmark-options"] + ("give extra options to benchmark executables " + ++ "(name templates can use $pkgid, $compiler, " + ++ "$os, $arch, $benchmark)") + benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) + (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs) + (const [])) + , option [] ["benchmark-option"] + ("give extra option to benchmark executables " + ++ "(no need to quote options containing spaces, " + ++ "name template can use $pkgid, $compiler, " + ++ "$os, $arch, $benchmark)") + benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) + (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) + (map fromPathTemplate)) + ] + +emptyBenchmarkFlags :: BenchmarkFlags +emptyBenchmarkFlags = mempty + +instance Monoid BenchmarkFlags where + mempty = BenchmarkFlags { + benchmarkDistPref = mempty, + benchmarkVerbosity = mempty, + benchmarkOptions = mempty + } + mappend a b = BenchmarkFlags { + benchmarkDistPref = combine benchmarkDistPref, + benchmarkVerbosity = combine benchmarkVerbosity, + benchmarkOptions = combine benchmarkOptions } where combine field = field a `mappend` field b diff --git a/Distribution/Simple/SrcDist.hs b/Distribution/Simple/SrcDist.hs --- a/Distribution/Simple/SrcDist.hs +++ b/Distribution/Simple/SrcDist.hs @@ -68,7 +68,8 @@ import Distribution.PackageDescription ( PackageDescription(..), BuildInfo(..), Executable(..), Library(..) - , TestSuite(..), TestSuiteInterface(..) ) + , TestSuite(..), TestSuiteInterface(..), Benchmark(..) + , BenchmarkInterface(..) ) import Distribution.PackageDescription.Check ( PackageCheck(..), checkConfiguredPackage, checkPackageFiles ) import Distribution.Package @@ -195,6 +196,23 @@ prep [m] bi TestSuiteUnsupported tp -> die $ "Unsupported test suite type: " ++ show tp + -- move the benchmarks into place + withBenchmark $ \bm -> do + let bi = benchmarkBuildInfo bm + prep = prepareDir verbosity pkg_descr distPref targetDir pps + case benchmarkInterface bm of + BenchmarkExeV10 _ mainPath -> do + prep [] bi + srcMainFile <- do + ppFile <- findFileWithExtension (ppSuffixes pps) + (hsSourceDirs bi) + (dropExtension mainPath) + case ppFile of + Nothing -> findFile (hsSourceDirs bi) mainPath + Just pp -> return pp + copyFileTo verbosity targetDir srcMainFile + BenchmarkUnsupported tp -> die $ "Unsupported benchmark type: " ++ show tp + flip mapM_ (dataFiles pkg_descr) $ \ filename -> do files <- matchFileGlob (dataDir pkg_descr filename) let dir = takeDirectory (dataDir pkg_descr filename) @@ -261,6 +279,7 @@ withLib action = maybe (return ()) action (library pkg_descr) withExe action = mapM_ action (executables pkg_descr) withTest action = mapM_ action (testSuites pkg_descr) + withBenchmark action = mapM_ action (benchmarks pkg_descr) -- | Prepare a directory tree of source files for a snapshot version. -- It is expected that the appropriate snapshot version has already been set @@ -411,8 +430,12 @@ -> (PackageDescription -> PackageDescription) mapAllBuildInfo f pkg = pkg { library = fmap mapLibBi (library pkg), - executables = fmap mapExeBi (executables pkg) + executables = fmap mapExeBi (executables pkg), + testSuites = fmap mapTestBi (testSuites pkg), + benchmarks = fmap mapBenchBi (benchmarks pkg) } where - mapLibBi lib = lib { libBuildInfo = f (libBuildInfo lib) } - mapExeBi exe = exe { buildInfo = f (buildInfo exe) } + mapLibBi lib = lib { libBuildInfo = f (libBuildInfo lib) } + mapExeBi exe = exe { buildInfo = f (buildInfo exe) } + mapTestBi t = t { testBuildInfo = f (testBuildInfo t) } + mapBenchBi bm = bm { benchmarkBuildInfo = f (benchmarkBuildInfo bm) } diff --git a/Distribution/Simple/Test.hs b/Distribution/Simple/Test.hs --- a/Distribution/Simple/Test.hs +++ b/Distribution/Simple/Test.hs @@ -63,7 +63,8 @@ import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar ) import Distribution.Simple.BuildPaths ( exeExtension ) import Distribution.Simple.Compiler ( Compiler(..), CompilerId ) -import Distribution.Simple.Hpc ( doHpcMarkup, findTixFiles, tixDir ) +import Distribution.Simple.Hpc + ( markupPackage, markupTest, tixDir, tixFilePath ) import Distribution.Simple.InstallDirs ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..) , substPathTemplate , toPathTemplate, PathTemplate ) @@ -82,8 +83,9 @@ import Data.Char ( toUpper ) import Data.Monoid ( mempty ) import System.Directory - ( createDirectoryIfMissing, doesFileExist, getCurrentDirectory - , removeFile, getDirectoryContents ) + ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist + , getCurrentDirectory, getDirectoryContents, removeDirectoryRecursive + , removeFile ) import System.Environment ( getEnvironment ) import System.Exit ( ExitCode(..), exitFailure, exitWith ) import System.FilePath ( (), (<.>) ) @@ -168,30 +170,35 @@ let distPref = fromFlag $ testDistPref flags verbosity = fromFlag $ testVerbosity flags testLogDir = distPref "test" - optionTemplates = fromFlag $ testOptions flags - options = map (testOption pkg_descr lbi suite) optionTemplates + options = map (testOption pkg_descr lbi suite) $ testOptions flags pwd <- getCurrentDirectory existingEnv <- getEnvironment let dataDirPath = pwd PD.dataDir pkg_descr shellEnv = Just $ (pkgPathEnvVar pkg_descr "datadir", dataDirPath) - : ("HPCTIXDIR", pwd tixDir distPref suite) + : ("HPCTIXFILE", () pwd + $ tixFilePath distPref $ PD.testName suite) : existingEnv bracket (openCabalTemp testLogDir) deleteIfExists $ \tempLog -> bracket (openCabalTemp testLogDir) deleteIfExists $ \tempInput -> do - -- Create directory for HPC files. - createDirectoryIfMissing True $ tixDir distPref suite + -- Check that the test executable exists. + exists <- doesFileExist cmd + unless exists $ die $ "Error: Could not find test program \"" ++ cmd + ++ "\". Did you build the package first?" -- Remove old .tix files if appropriate. - tixFiles <- findTixFiles distPref suite - unless (fromFlag $ testKeepTix flags) - $ mapM_ deleteIfExists tixFiles + unless (fromFlag $ testKeepTix flags) $ do + let tDir = tixDir distPref $ PD.testName suite + exists <- doesDirectoryExist tDir + when exists $ removeDirectoryRecursive tDir + -- Create directory for HPC files. + createDirectoryIfMissing True $ tixDir distPref $ PD.testName suite + -- Write summary notices indicating start of test suite notice verbosity $ summarizeSuiteStart $ PD.testName suite - appendFile tempLog $ summarizeSuiteStart $ PD.testName suite -- Prepare standard input for test executable appendFile tempInput $ preTest tempInput @@ -207,32 +214,36 @@ -- Generate TestSuiteLog from executable exit code and a machine- -- readable test log - suiteLog <- readFile tempInput >>= return . postTest exit + suiteLog <- fmap (postTest exit $!) $ readFile tempInput -- Generate final log file name let finalLogName = testLogDir logNamer suiteLog suiteLog' = suiteLog { logFile = finalLogName } - -- Write summary notice to log file indicating end of test suite - appendFile tempLog $ summarizeSuiteFinish suiteLog' + -- Write summary notice to log file indicating start of test suite + appendFile (logFile suiteLog') $ summarizeSuiteStart $ PD.testName suite -- Append contents of temporary log file to the final human- -- readable log file readFile tempLog >>= appendFile (logFile suiteLog') + -- Write end-of-suite summary notice to log file + appendFile (logFile suiteLog') $ summarizeSuiteFinish suiteLog' + -- Show the contents of the human-readable log file on the terminal -- if there is a failure and/or detailed output is requested let details = fromFlag $ testShowDetails flags whenPrinting = when $ (details > Never) && (not (suitePassed suiteLog) || details == Always) && verbosity >= normal - whenPrinting $ readFile (logFile suiteLog') >>= - putStr . unlines . map (">>> " ++) . lines + whenPrinting $ readFile tempLog >>= + putStr . unlines . lines -- Write summary notice to terminal indicating end of test suite notice verbosity $ summarizeSuiteFinish suiteLog' - doHpcMarkup verbosity distPref (display $ PD.package pkg_descr) suite + markupTest verbosity lbi distPref + (display $ PD.package pkg_descr) suite return suiteLog' where @@ -343,6 +354,10 @@ $ packageLogPath machineTemplate pkg_descr lbi allOk <- summarizePackage verbosity packageLog writeFile packageLogFile $ show packageLog + + markupPackage verbosity lbi distPref (display $ PD.package pkg_descr) + $ map fst testsToRun + unless allOk exitFailure -- | Print a summary to the console after all test suites have been run diff --git a/Distribution/Simple/UserHooks.hs b/Distribution/Simple/UserHooks.hs --- a/Distribution/Simple/UserHooks.hs +++ b/Distribution/Simple/UserHooks.hs @@ -66,7 +66,7 @@ import Distribution.Simple.Setup (ConfigFlags, BuildFlags, CleanFlags, CopyFlags, InstallFlags, SDistFlags, RegisterFlags, HscolourFlags, - HaddockFlags, TestFlags) + HaddockFlags, TestFlags, BenchmarkFlags) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo) type Args = [String] @@ -168,7 +168,14 @@ -- |Over-ride this hook to get different behavior during test. testHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO (), -- |Hook to run after test command. - postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO () + postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before bench command. + preBench :: Args -> BenchmarkFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during bench. + benchHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> BenchmarkFlags -> IO (), + -- |Hook to run after bench command. + postBench :: Args -> BenchmarkFlags -> PackageDescription -> LocalBuildInfo -> IO () } {-# DEPRECATED runTests "Please use the new testing interface instead!" #-} @@ -214,7 +221,11 @@ preTest = \_ _ -> return emptyHookedBuildInfo, -- same as rn, but without -- noExtraFlags testHook = ru, - postTest = ru + postTest = ru, + preBench = \_ _ -> return emptyHookedBuildInfo, -- same as rn, but without + -- noExtraFlags + benchHook = \_ -> ru, + postBench = ru } where rn args _ = noExtraFlags args >> return emptyHookedBuildInfo ru _ _ _ _ = return () diff --git a/Distribution/Simple/Utils.hs b/Distribution/Simple/Utils.hs --- a/Distribution/Simple/Utils.hs +++ b/Distribution/Simple/Utils.hs @@ -58,6 +58,7 @@ -- * running programs rawSystemExit, + rawSystemExitCode, rawSystemExitWithEnv, rawSystemStdout, rawSystemStdInOut, @@ -374,6 +375,15 @@ debug verbosity $ path ++ " returned " ++ show exitcode exitWith exitcode +rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode +rawSystemExitCode verbosity path args = do + printRawCommandAndArgs verbosity path args + hFlush stdout + exitcode <- rawSystem path args + unless (exitcode == ExitSuccess) $ do + debug verbosity $ path ++ " returned " ++ show exitcode + return exitcode + rawSystemExitWithEnv :: Verbosity -> FilePath -> [String] @@ -979,7 +989,7 @@ multiDesc :: [String] -> IO a multiDesc l = die $ "Multiple cabal files found.\n" ++ "Please use only one of: " - ++ show l + ++ intercalate ", " l -- |Optional auxiliary package information file (/pkgname/@.buildinfo@) defaultHookedPackageDesc :: IO (Maybe FilePath) diff --git a/Language/Haskell/Extension.hs b/Language/Haskell/Extension.hs --- a/Language/Haskell/Extension.hs +++ b/Language/Haskell/Extension.hs @@ -436,6 +436,30 @@ -- | Enable non-decreasing indentation for 'do' blocks. | NondecreasingIndentation + -- | [GHC § 7.20.3] Allow imports to be qualified with a safe + -- keyword that requires the imported module be trusted as according + -- to the Safe Haskell definition of trust. + -- + -- > import safe Network.Socket + | SafeImports + + -- | [GHC § 7.20] Compile a module in the Safe, Safe Haskell + -- mode -- a restricted form of the Haskell language to ensure + -- type safety. + | Safe + + -- | [GHC § 7.20] Compile a module in the Trustworthy, Safe + -- Haskell mode -- no restrictions apply but the module is marked + -- as trusted as long as the package the module resides in is + -- trusted. + | Trustworthy + + -- | [GHC § 7.40] Allow type class/implicit parameter/equality + -- constraints to be used as types with the special kind Constraint. + -- Also generalise the (ctxt => ty) syntax so that any type of kind + -- Constraint can occur before the arrow. + | ConstraintKinds + deriving (Show, Read, Eq, Enum, Bounded) {-# DEPRECATED knownExtensions diff --git a/tests/PackageTests/BenchmarkStanza/Check.hs b/tests/PackageTests/BenchmarkStanza/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/BenchmarkStanza/Check.hs @@ -0,0 +1,57 @@ +module PackageTests.BenchmarkStanza.Check where + +import Test.HUnit +import System.FilePath +import PackageTests.PackageTester +import Data.List (isInfixOf, intercalate) +import Distribution.Version +import Distribution.PackageDescription.Parse + ( readPackageDescription ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import Distribution.Package + ( PackageIdentifier(..), PackageName(..), Dependency(..) ) +import Distribution.PackageDescription + ( PackageDescription(..), BuildInfo(..), Benchmark(..), Library(..) + , BenchmarkInterface(..) + , TestType(..), emptyPackageDescription, emptyBuildInfo, emptyLibrary + , emptyBenchmark, BuildType(..) ) +import Distribution.Verbosity (silent) +import Distribution.License (License(..)) +import Distribution.ModuleName (fromString) +import Distribution.System (buildPlatform) +import Distribution.Compiler + ( CompilerId(..), CompilerFlavor(..) ) +import Distribution.Text + +suite :: Version -> Test +suite cabalVersion = TestCase $ do + let directory = "PackageTests" "BenchmarkStanza" + pdFile = directory "my" <.> "cabal" + spec = PackageSpec directory [] + result <- cabal_configure spec + let message = "cabal configure should recognize benchmark section" + test = "unknown section type" + `isInfixOf` + (intercalate " " $ lines $ outputText result) + assertEqual message False test + genPD <- readPackageDescription silent pdFile + let compiler = CompilerId GHC $ Version [6, 12, 2] [] + anyV = intersectVersionRanges anyVersion anyVersion + anticipatedBenchmark = emptyBenchmark + { benchmarkName = "dummy" + , benchmarkInterface = BenchmarkExeV10 (Version [1,0] []) "dummy.hs" + , benchmarkBuildInfo = emptyBuildInfo + { targetBuildDepends = + [ Dependency (PackageName "base") anyVersion ] + , hsSourceDirs = ["."] + } + , benchmarkEnabled = False + } + case finalizePackageDescription [] (const True) buildPlatform compiler [] genPD of + Left xs -> let depMessage = "should not have missing dependencies:\n" ++ + (unlines $ map (show . disp) xs) + in assertEqual depMessage True False + Right (f, _) -> let gotBenchmark = head $ benchmarks f + in assertEqual "parsed benchmark stanza does not match anticipated" + gotBenchmark anticipatedBenchmark diff --git a/tests/PackageTests/PackageTester.hs b/tests/PackageTests/PackageTester.hs --- a/tests/PackageTests/PackageTester.hs +++ b/tests/PackageTests/PackageTester.hs @@ -5,6 +5,7 @@ cabal_configure, cabal_build, cabal_test, + cabal_bench, cabal_install, unregister, run @@ -32,7 +33,13 @@ configOpts :: [String] } -data Success = Failure | ConfigureSuccess | BuildSuccess | InstallSuccess | TestSuccess deriving (Eq, Show) +data Success = Failure + | ConfigureSuccess + | BuildSuccess + | InstallSuccess + | TestSuccess + | BenchSuccess + deriving (Eq, Show) data Result = Result { successful :: Bool, @@ -104,10 +111,17 @@ record spec res return res -cabal_test :: PackageSpec -> IO Result -cabal_test spec = do - res <- cabal spec ["test"] +cabal_test :: PackageSpec -> [String] -> IO Result +cabal_test spec extraArgs = do + res <- cabal spec $ "test" : extraArgs let r = recordRun res TestSuccess nullResult + record spec r + return r + +cabal_bench :: PackageSpec -> [String] -> IO Result +cabal_bench spec extraArgs = do + res <- cabal spec $ "bench" : extraArgs + let r = recordRun res BenchSuccess nullResult record spec r return r diff --git a/tests/PackageTests/TestOptions/Check.hs b/tests/PackageTests/TestOptions/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/TestOptions/Check.hs @@ -0,0 +1,23 @@ +module PackageTests.TestOptions.Check where + +import Test.HUnit +import System.FilePath +import PackageTests.PackageTester + +suite :: Test +suite = TestCase $ do + let directory = "PackageTests" "TestOptions" + pdFile = directory "TestOptions" <.> "cabal" + spec = PackageSpec directory ["--enable-tests"] + _ <- cabal_build spec + result <- cabal_test spec ["--test-options=1 2 3"] + let message = "\"cabal test\" did not pass the correct options to the " + ++ "test executable with \"--test-options\"" + assertEqual message True $ successful result + result' <- cabal_test spec [ "--test-option=1" + , "--test-option=2" + , "--test-option=3" + ] + let message = "\"cabal test\" did not pass the correct options to the " + ++ "test executable with \"--test-option\"" + assertEqual message True $ successful result' diff --git a/tests/PackageTests/TestSuiteExeV10/Check.hs b/tests/PackageTests/TestSuiteExeV10/Check.hs --- a/tests/PackageTests/TestSuiteExeV10/Check.hs +++ b/tests/PackageTests/TestSuiteExeV10/Check.hs @@ -20,7 +20,7 @@ buildResult <- cabal_build spec let buildMessage = "\'setup build\' should succeed" assertEqual buildMessage True $ successful buildResult - testResult <- cabal_test spec + testResult <- cabal_test spec [] let testMessage = "\'setup test\' should succeed" assertEqual testMessage True $ successful testResult @@ -32,13 +32,13 @@ buildResult <- cabal_build spec let buildMessage = "\'setup build\' should succeed" assertEqual buildMessage True $ successful buildResult - testResult <- cabal_test spec + testResult <- cabal_test spec [] let testMessage = "\'setup test\' should succeed" assertEqual testMessage True $ successful testResult let dummy = emptyTestSuite { testName = "test-Foo" } - tixFile = tixFilePath (dir "dist") dummy + tixFile = tixFilePath (dir "dist") $ testName dummy tixFileMessage = ".tix file should exist" - markupDir = tixDir (dir "dist") dummy + markupDir = htmlDir (dir "dist") $ testName dummy markupFile = markupDir "hpc_index" <.> "html" markupFileMessage = "HPC markup file should exist" tixFileExists <- doesFileExist tixFile diff --git a/tests/suite.hs b/tests/suite.hs --- a/tests/suite.hs +++ b/tests/suite.hs @@ -10,6 +10,9 @@ import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 import qualified Test.HUnit as HUnit +import PackageTests.BenchmarkExeV10.Check +import PackageTests.BenchmarkOptions.Check +import PackageTests.BenchmarkStanza.Check import PackageTests.BuildDeps.SameDepsAllRound.Check import PackageTests.BuildDeps.TargetSpecificDeps1.Check import PackageTests.BuildDeps.TargetSpecificDeps1.Check @@ -22,6 +25,7 @@ import PackageTests.BuildDeps.InternalLibrary2.Check import PackageTests.BuildDeps.InternalLibrary3.Check import PackageTests.BuildDeps.InternalLibrary4.Check +import PackageTests.TestOptions.Check import PackageTests.TestStanza.Check import PackageTests.TestSuiteExeV10.Check import Distribution.Text (display) @@ -44,7 +48,14 @@ hunit "PackageTests/TestSuiteExeV10/Test" (PackageTests.TestSuiteExeV10.Check.checkTest cabalVersion), hunit "PackageTests/TestSuiteExeV10/TestWithHpc" - (PackageTests.TestSuiteExeV10.Check.checkTestWithHpc cabalVersion) + (PackageTests.TestSuiteExeV10.Check.checkTestWithHpc cabalVersion), + hunit "PackageTests/TestOptions" PackageTests.TestOptions.Check.suite, + hunit "PackageTests/BenchmarkStanza/" (PackageTests.BenchmarkStanza.Check.suite cabalVersion), + -- ^ The benchmark stanza test will eventually be required + -- only for higher versions. + hunit "PackageTests/BenchmarkExeV10/Test" + (PackageTests.BenchmarkExeV10.Check.checkBenchmark cabalVersion), + hunit "PackageTests/BenchmarkOptions" PackageTests.BenchmarkOptions.Check.suite ] ++ -- These tests are only required to pass on cabal version >= 1.7 (if cabalVersion >= Version [1, 7] []