Cabal 1.12.0 → 1.14.0

raw patch · 35 files changed

+1287/−295 lines, 35 filesdep ~arraydep ~filepathdep ~old-timePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: array, filepath, old-time

API changes (from Hackage documentation)

Files

• Cabal.cabal +9/−4
• Distribution/PackageDescription.hs +147/−10
• Distribution/PackageDescription/Check.hs +57/−21
• Distribution/PackageDescription/Configuration.hs +56/−22
• Distribution/PackageDescription/Parse.hs +144/−15
• Distribution/ParseUtils.hs +1/−1
• Distribution/Simple.hs +28/−2
• Distribution/Simple/Bench.hs +156/−0
• Distribution/Simple/Build.hs +78/−14
• Distribution/Simple/Command.hs +1/−1
• Distribution/Simple/Configure.hs +35/−29
• Distribution/Simple/GHC.hs +7/−3
• Distribution/Simple/GHC/IPI641.hs +1/−1
• Distribution/Simple/GHC/IPI642.hs +1/−1
• Distribution/Simple/Haddock.hs +17/−8
• Distribution/Simple/Hpc.hs +65/−80
• Distribution/Simple/InstallDirs.hs +5/−1
• Distribution/Simple/LocalBuildInfo.hs +40/−16
• Distribution/Simple/PreProcess.hs +18/−6
• Distribution/Simple/Program.hs +1/−0
• Distribution/Simple/Program/Builtin.hs +10/−0
• Distribution/Simple/Program/Hpc.hs +73/−0
• Distribution/Simple/Program/Types.hs +24/−16
• Distribution/Simple/Register.hs +1/−1
• Distribution/Simple/Setup.hs +89/−8
• Distribution/Simple/SrcDist.hs +27/−4
• Distribution/Simple/Test.hs +33/−18
• Distribution/Simple/UserHooks.hs +14/−3
• Distribution/Simple/Utils.hs +11/−1
• Language/Haskell/Extension.hs +24/−0
• tests/PackageTests/BenchmarkStanza/Check.hs +57/−0
• tests/PackageTests/PackageTester.hs +18/−4
• tests/PackageTests/TestOptions/Check.hs +23/−0
• tests/PackageTests/TestSuiteExeV10/Check.hs +4/−4
• tests/suite.hs +12/−1

@@ -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:

@@ -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) 

@@ -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

@@ -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 =

@@ -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] ->

@@ -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)

@@ -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 ()

@@ -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)]

@@ -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

@@ -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.

@@ -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}

@@ -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

@@ -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,

@@ -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,

@@ -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,

@@ -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"

@@ -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

@@ -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"  

@@ -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 

@@ -110,6 +110,7 @@     , tarProgram     , cppProgram     , pkgConfigProgram+    , hpcProgram      -- * deprecated     , rawSystemProgram

@@ -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

@@ -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 ]+        ]

@@ -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   }-

@@ -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

@@ -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 

@@ -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) }

@@ -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

@@ -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 ()

@@ -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)

@@ -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

@@ -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

@@ -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 

@@ -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'

@@ -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

@@ -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] []