{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Distribution.Simple.Bench
( bench
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Types.UnqualComponentName
import qualified Distribution.PackageDescription as PD
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler
import Distribution.Simple.InstallDirs
import qualified Distribution.Simple.LocalBuildInfo as LBI
import Distribution.Simple.Setup
import Distribution.Simple.UserHooks
import Distribution.Simple.Utils
import Distribution.Pretty
import System.Directory ( doesFileExist )
import System.FilePath ( (</>), (<.>) )
bench :: Args
-> PD.PackageDescription
-> LBI.LocalBuildInfo
-> BenchmarkFlags
-> IO ()
bench :: Args
-> PackageDescription -> LocalBuildInfo -> BenchmarkFlags -> IO ()
bench Args
args PackageDescription
pkg_descr LocalBuildInfo
lbi BenchmarkFlags
flags = do
let verbosity :: Verbosity
verbosity = forall a. WithCallStack (Flag a -> a)
fromFlag forall a b. (a -> b) -> a -> b
$ BenchmarkFlags -> Flag Verbosity
benchmarkVerbosity BenchmarkFlags
flags
benchmarkNames :: Args
benchmarkNames = Args
args
pkgBenchmarks :: [Benchmark]
pkgBenchmarks = PackageDescription -> [Benchmark]
PD.benchmarks PackageDescription
pkg_descr
enabledBenchmarks :: [Benchmark]
enabledBenchmarks = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (PackageDescription
-> LocalBuildInfo -> [(Benchmark, ComponentLocalBuildInfo)]
LBI.enabledBenchLBIs PackageDescription
pkg_descr LocalBuildInfo
lbi)
doBench :: PD.Benchmark -> IO ExitCode
doBench :: Benchmark -> IO ExitCode
doBench Benchmark
bm =
case Benchmark -> BenchmarkInterface
PD.benchmarkInterface Benchmark
bm of
PD.BenchmarkExeV10 Version
_ FilePath
_ -> do
let cmd :: FilePath
cmd = LocalBuildInfo -> FilePath
LBI.buildDir LocalBuildInfo
lbi FilePath -> FilePath -> FilePath
</> FilePath
name FilePath -> FilePath -> FilePath
</> FilePath
name FilePath -> FilePath -> FilePath
<.> Platform -> FilePath
exeExtension (LocalBuildInfo -> Platform
LBI.hostPlatform LocalBuildInfo
lbi)
options :: Args
options = forall a b. (a -> b) -> [a] -> [b]
map (PackageDescription
-> LocalBuildInfo -> Benchmark -> PathTemplate -> FilePath
benchOption PackageDescription
pkg_descr LocalBuildInfo
lbi Benchmark
bm) forall a b. (a -> b) -> a -> b
$
BenchmarkFlags -> [PathTemplate]
benchmarkOptions BenchmarkFlags
flags
Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
cmd
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$ forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
FilePath
"Error: Could not find benchmark program \""
forall a. [a] -> [a] -> [a]
++ FilePath
cmd forall a. [a] -> [a] -> [a]
++ FilePath
"\". Did you build the package first?"
Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
startMessage FilePath
name
ExitCode
exitcode <- Verbosity -> FilePath -> Args -> IO ExitCode
rawSystemExitCode Verbosity
verbosity FilePath
cmd Args
options
Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath -> ExitCode -> FilePath
finishMessage FilePath
name ExitCode
exitcode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
exitcode
BenchmarkInterface
_ -> do
Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"No support for running "
forall a. [a] -> [a] -> [a]
++ FilePath
"benchmark " forall a. [a] -> [a] -> [a]
++ FilePath
name forall a. [a] -> [a] -> [a]
++ FilePath
" of type: "
forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> FilePath
prettyShow (Benchmark -> BenchmarkType
PD.benchmarkType Benchmark
bm)
forall a. IO a
exitFailure
where name :: FilePath
name = UnqualComponentName -> FilePath
unUnqualComponentName forall a b. (a -> b) -> a -> b
$ Benchmark -> UnqualComponentName
PD.benchmarkName Benchmark
bm
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PackageDescription -> Bool
PD.hasBenchmarks PackageDescription
pkg_descr) forall a b. (a -> b) -> a -> b
$ do
Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity FilePath
"Package has no benchmarks."
forall a. IO a
exitSuccess
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PackageDescription -> Bool
PD.hasBenchmarks PackageDescription
pkg_descr Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Benchmark]
enabledBenchmarks) forall a b. (a -> b) -> a -> b
$
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"No benchmarks enabled. Did you remember to configure with "
forall a. [a] -> [a] -> [a]
++ FilePath
"\'--enable-benchmarks\'?"
[Benchmark]
bmsToRun <- case Args
benchmarkNames of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return [Benchmark]
enabledBenchmarks
Args
names -> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Args
names forall a b. (a -> b) -> a -> b
$ \FilePath
bmName ->
let benchmarkMap :: [(UnqualComponentName, Benchmark)]
benchmarkMap = forall a b. [a] -> [b] -> [(a, b)]
zip [UnqualComponentName]
enabledNames [Benchmark]
enabledBenchmarks
enabledNames :: [UnqualComponentName]
enabledNames = forall a b. (a -> b) -> [a] -> [b]
map Benchmark -> UnqualComponentName
PD.benchmarkName [Benchmark]
enabledBenchmarks
allNames :: [UnqualComponentName]
allNames = forall a b. (a -> b) -> [a] -> [b]
map Benchmark -> UnqualComponentName
PD.benchmarkName [Benchmark]
pkgBenchmarks
in case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (FilePath -> UnqualComponentName
mkUnqualComponentName FilePath
bmName) [(UnqualComponentName, Benchmark)]
benchmarkMap of
Just Benchmark
t -> forall (m :: * -> *) a. Monad m => a -> m a
return Benchmark
t
Maybe Benchmark
_ | FilePath -> UnqualComponentName
mkUnqualComponentName FilePath
bmName forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UnqualComponentName]
allNames ->
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"Package configured with benchmark "
forall a. [a] -> [a] -> [a]
++ FilePath
bmName forall a. [a] -> [a] -> [a]
++ FilePath
" disabled."
| Bool
otherwise -> forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"no such benchmark: " forall a. [a] -> [a] -> [a]
++ FilePath
bmName
let totalBenchmarks :: Int
totalBenchmarks = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Benchmark]
bmsToRun
Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"Running " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Int
totalBenchmarks forall a. [a] -> [a] -> [a]
++ FilePath
" benchmarks..."
[ExitCode]
exitcodes <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Benchmark -> IO ExitCode
doBench [Benchmark]
bmsToRun
let allOk :: Bool
allOk = Int
totalBenchmarks forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) [ExitCode]
exitcodes)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
allOk forall a. IO a
exitFailure
where
startMessage :: FilePath -> FilePath
startMessage FilePath
name = FilePath
"Benchmark " forall a. [a] -> [a] -> [a]
++ FilePath
name forall a. [a] -> [a] -> [a]
++ FilePath
": RUNNING...\n"
finishMessage :: FilePath -> ExitCode -> FilePath
finishMessage FilePath
name ExitCode
exitcode = FilePath
"Benchmark " forall a. [a] -> [a] -> [a]
++ FilePath
name forall a. [a] -> [a] -> [a]
++ FilePath
": "
forall a. [a] -> [a] -> [a]
++ (case ExitCode
exitcode of
ExitCode
ExitSuccess -> FilePath
"FINISH"
ExitFailure Int
_ -> FilePath
"ERROR")
benchOption :: PD.PackageDescription
-> LBI.LocalBuildInfo
-> PD.Benchmark
-> PathTemplate
-> String
benchOption :: PackageDescription
-> LocalBuildInfo -> Benchmark -> PathTemplate -> FilePath
benchOption PackageDescription
pkg_descr LocalBuildInfo
lbi Benchmark
bm PathTemplate
template =
PathTemplate -> FilePath
fromPathTemplate forall a b. (a -> b) -> a -> b
$ PathTemplateEnv -> PathTemplate -> PathTemplate
substPathTemplate PathTemplateEnv
env PathTemplate
template
where
env :: PathTemplateEnv
env = PackageIdentifier
-> UnitId -> CompilerInfo -> Platform -> PathTemplateEnv
initialPathTemplateEnv
(PackageDescription -> PackageIdentifier
PD.package PackageDescription
pkg_descr) (LocalBuildInfo -> UnitId
LBI.localUnitId LocalBuildInfo
lbi)
(Compiler -> CompilerInfo
compilerInfo forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> Compiler
LBI.compiler LocalBuildInfo
lbi) (LocalBuildInfo -> Platform
LBI.hostPlatform LocalBuildInfo
lbi) forall a. [a] -> [a] -> [a]
++
[(PathTemplateVariable
BenchmarkNameVar, FilePath -> PathTemplate
toPathTemplate forall a b. (a -> b) -> a -> b
$ UnqualComponentName -> FilePath
unUnqualComponentName forall a b. (a -> b) -> a -> b
$ Benchmark -> UnqualComponentName
PD.benchmarkName Benchmark
bm)]