{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
module Distribution.Simple.Bench
( bench
) where
import Distribution.Compat.Prelude
import Prelude ()
import Distribution.Compat.Environment
import qualified Distribution.PackageDescription as PD
import Distribution.Pretty
import Distribution.Simple.Build (addInternalBuildTools)
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler
import Distribution.Simple.Errors
import Distribution.Simple.InstallDirs
import qualified Distribution.Simple.LocalBuildInfo as LBI
import Distribution.Simple.Program.Db
import Distribution.Simple.Program.Find
import Distribution.Simple.Program.Run
import Distribution.Simple.Setup.Benchmark
import Distribution.Simple.Setup.Common
import Distribution.Simple.UserHooks
import Distribution.Simple.Utils
import Distribution.System (Platform (Platform))
import Distribution.Types.Benchmark (Benchmark (benchmarkBuildInfo))
import Distribution.Types.UnqualComponentName
import Distribution.Utils.Path
import System.Directory (doesFileExist)
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 = Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Verbosity -> Verbosity) -> Flag Verbosity -> Verbosity
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, ComponentLocalBuildInfo)]
enabledBenchmarks = PackageDescription
-> LocalBuildInfo -> [(Benchmark, ComponentLocalBuildInfo)]
LBI.enabledBenchLBIs PackageDescription
pkg_descr LocalBuildInfo
lbi
mbWorkDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir = Flag (SymbolicPath CWD ('Dir Pkg))
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Flag a -> Maybe a
flagToMaybe (Flag (SymbolicPath CWD ('Dir Pkg))
-> Maybe (SymbolicPath CWD ('Dir Pkg)))
-> Flag (SymbolicPath CWD ('Dir Pkg))
-> Maybe (SymbolicPath CWD ('Dir Pkg))
forall a b. (a -> b) -> a -> b
$ BenchmarkFlags -> Flag (SymbolicPath CWD ('Dir Pkg))
benchmarkWorkingDir BenchmarkFlags
flags
i :: SymbolicPathX allowAbsolute Pkg to -> FilePath
i = Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX allowAbsolute Pkg to -> FilePath
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> FilePath
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir
doBench :: (PD.Benchmark, LBI.ComponentLocalBuildInfo) -> IO ExitCode
doBench :: (Benchmark, ComponentLocalBuildInfo) -> IO ExitCode
doBench (Benchmark
bm, ComponentLocalBuildInfo
clbi) = do
let lbiForBench :: LocalBuildInfo
lbiForBench =
LocalBuildInfo
lbi
{
LBI.withPrograms =
addInternalBuildTools
pkg_descr
lbi
(benchmarkBuildInfo bm)
(LBI.withPrograms lbi)
}
case Benchmark -> BenchmarkInterface
PD.benchmarkInterface Benchmark
bm of
PD.BenchmarkExeV10 Version
_ RelativePath Source 'File
_ -> do
let cmd :: FilePath
cmd = SymbolicPathX 'AllowAbsolute Pkg Any -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i (SymbolicPathX 'AllowAbsolute Pkg Any -> FilePath)
-> SymbolicPathX 'AllowAbsolute Pkg Any -> FilePath
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> SymbolicPath Pkg ('Dir Build)
LBI.buildDir LocalBuildInfo
lbiForBench SymbolicPath Pkg ('Dir Build)
-> RelativePath Build Any -> SymbolicPathX 'AllowAbsolute Pkg Any
forall p q r. PathLike p q r => p -> q -> r
</> FilePath -> RelativePath Build Any
forall from (to :: FileOrDir).
HasCallStack =>
FilePath -> RelativePath from to
makeRelativePathEx (FilePath
name FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
name FilePath -> FilePath -> FilePath
forall p. FileLike p => p -> FilePath -> p
<.> Platform -> FilePath
exeExtension (LocalBuildInfo -> Platform
LBI.hostPlatform LocalBuildInfo
lbi))
options :: Args
options =
(PathTemplate -> FilePath) -> [PathTemplate] -> Args
forall a b. (a -> b) -> [a] -> [b]
map (PackageDescription
-> LocalBuildInfo -> Benchmark -> PathTemplate -> FilePath
benchOption PackageDescription
pkg_descr LocalBuildInfo
lbiForBench Benchmark
bm) ([PathTemplate] -> Args) -> [PathTemplate] -> Args
forall a b. (a -> b) -> a -> b
$
BenchmarkFlags -> [PathTemplate]
benchmarkOptions BenchmarkFlags
flags
Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
cmd
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO ()) -> CabalException -> IO ()
forall a b. (a -> b) -> a -> b
$
FilePath -> CabalException
NoBenchMarkProgram FilePath
cmd
[(FilePath, FilePath)]
existingEnv <- IO [(FilePath, FilePath)]
getEnvironment
let progDb :: ProgramDb
progDb = LocalBuildInfo -> ProgramDb
LBI.withPrograms LocalBuildInfo
lbiForBench
pathVar :: ProgramSearchPath
pathVar = ProgramDb -> ProgramSearchPath
progSearchPath ProgramDb
progDb
envOverrides :: [(FilePath, Maybe FilePath)]
envOverrides = ProgramDb -> [(FilePath, Maybe FilePath)]
progOverrideEnv ProgramDb
progDb
FilePath
newPath <- ProgramSearchPath -> IO FilePath
programSearchPathAsPATHVar ProgramSearchPath
pathVar
[(FilePath, FilePath)]
overrideEnv <- [(FilePath, FilePath)]
-> Maybe [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [(FilePath, FilePath)] -> [(FilePath, FilePath)])
-> IO (Maybe [(FilePath, FilePath)]) -> IO [(FilePath, FilePath)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(FilePath, Maybe FilePath)] -> IO (Maybe [(FilePath, FilePath)])
getEffectiveEnvironment ([(FilePath
"PATH", FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
newPath)] [(FilePath, Maybe FilePath)]
-> [(FilePath, Maybe FilePath)] -> [(FilePath, Maybe FilePath)]
forall a. [a] -> [a] -> [a]
++ [(FilePath, Maybe FilePath)]
envOverrides)
let shellEnv :: [(FilePath, FilePath)]
shellEnv = [(FilePath, FilePath)]
overrideEnv [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++ [(FilePath, FilePath)]
existingEnv
[(FilePath, FilePath)]
shellEnv' <-
if LocalBuildInfo -> Bool
LBI.withDynExe LocalBuildInfo
lbiForBench
then do
let (Platform Arch
_ OS
os) = LocalBuildInfo -> Platform
LBI.hostPlatform LocalBuildInfo
lbiForBench
Args
paths <- Bool
-> Bool -> LocalBuildInfo -> ComponentLocalBuildInfo -> IO Args
LBI.depLibraryPaths Bool
True Bool
False LocalBuildInfo
lbiForBench ComponentLocalBuildInfo
clbi
[(FilePath, FilePath)] -> IO [(FilePath, FilePath)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (OS -> Args -> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
addLibraryPath OS
os Args
paths [(FilePath, FilePath)]
shellEnv)
else [(FilePath, FilePath)] -> IO [(FilePath, FilePath)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(FilePath, FilePath)]
shellEnv
Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
startMessage FilePath
name
ExitCode
exitcode <- Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> FilePath
-> Args
-> Maybe [(FilePath, FilePath)]
-> IO ExitCode
rawSystemExitCode Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir FilePath
cmd Args
options ([(FilePath, FilePath)] -> Maybe [(FilePath, FilePath)]
forall a. a -> Maybe a
Just [(FilePath, FilePath)]
shellEnv')
Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ExitCode -> FilePath
finishMessage FilePath
name ExitCode
exitcode
ExitCode -> IO ExitCode
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
exitcode
BenchmarkInterface
_ -> do
Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
FilePath
"No support for running "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"benchmark "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
name
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" of type: "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ BenchmarkType -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (Benchmark -> BenchmarkType
PD.benchmarkType Benchmark
bm)
IO ExitCode
forall a. IO a
exitFailure
where
name :: FilePath
name = UnqualComponentName -> FilePath
unUnqualComponentName (UnqualComponentName -> FilePath)
-> UnqualComponentName -> FilePath
forall a b. (a -> b) -> a -> b
$ Benchmark -> UnqualComponentName
PD.benchmarkName Benchmark
bm
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PackageDescription -> Bool
PD.hasBenchmarks PackageDescription
pkg_descr) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity FilePath
"Package has no benchmarks."
IO ()
forall a. IO a
exitSuccess
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PackageDescription -> Bool
PD.hasBenchmarks PackageDescription
pkg_descr Bool -> Bool -> Bool
&& [(Benchmark, ComponentLocalBuildInfo)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Benchmark, ComponentLocalBuildInfo)]
enabledBenchmarks) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalException
EnableBenchMark
[(Benchmark, ComponentLocalBuildInfo)]
bmsToRun <- case Args
benchmarkNames of
[] -> [(Benchmark, ComponentLocalBuildInfo)]
-> IO [(Benchmark, ComponentLocalBuildInfo)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Benchmark, ComponentLocalBuildInfo)]
enabledBenchmarks
Args
names -> Args
-> (FilePath -> IO (Benchmark, ComponentLocalBuildInfo))
-> IO [(Benchmark, ComponentLocalBuildInfo)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Args
names ((FilePath -> IO (Benchmark, ComponentLocalBuildInfo))
-> IO [(Benchmark, ComponentLocalBuildInfo)])
-> (FilePath -> IO (Benchmark, ComponentLocalBuildInfo))
-> IO [(Benchmark, ComponentLocalBuildInfo)]
forall a b. (a -> b) -> a -> b
$ \FilePath
bmName ->
let benchmarkMap :: [(UnqualComponentName, (Benchmark, ComponentLocalBuildInfo))]
benchmarkMap = [UnqualComponentName]
-> [(Benchmark, ComponentLocalBuildInfo)]
-> [(UnqualComponentName, (Benchmark, ComponentLocalBuildInfo))]
forall a b. [a] -> [b] -> [(a, b)]
zip [UnqualComponentName]
enabledNames [(Benchmark, ComponentLocalBuildInfo)]
enabledBenchmarks
enabledNames :: [UnqualComponentName]
enabledNames = ((Benchmark, ComponentLocalBuildInfo) -> UnqualComponentName)
-> [(Benchmark, ComponentLocalBuildInfo)] -> [UnqualComponentName]
forall a b. (a -> b) -> [a] -> [b]
map (Benchmark -> UnqualComponentName
PD.benchmarkName (Benchmark -> UnqualComponentName)
-> ((Benchmark, ComponentLocalBuildInfo) -> Benchmark)
-> (Benchmark, ComponentLocalBuildInfo)
-> UnqualComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Benchmark, ComponentLocalBuildInfo) -> Benchmark
forall a b. (a, b) -> a
fst) [(Benchmark, ComponentLocalBuildInfo)]
enabledBenchmarks
allNames :: [UnqualComponentName]
allNames = (Benchmark -> UnqualComponentName)
-> [Benchmark] -> [UnqualComponentName]
forall a b. (a -> b) -> [a] -> [b]
map Benchmark -> UnqualComponentName
PD.benchmarkName [Benchmark]
pkgBenchmarks
in case UnqualComponentName
-> [(UnqualComponentName, (Benchmark, ComponentLocalBuildInfo))]
-> Maybe (Benchmark, ComponentLocalBuildInfo)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (FilePath -> UnqualComponentName
mkUnqualComponentName FilePath
bmName) [(UnqualComponentName, (Benchmark, ComponentLocalBuildInfo))]
benchmarkMap of
Just (Benchmark, ComponentLocalBuildInfo)
t -> (Benchmark, ComponentLocalBuildInfo)
-> IO (Benchmark, ComponentLocalBuildInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Benchmark, ComponentLocalBuildInfo)
t
Maybe (Benchmark, ComponentLocalBuildInfo)
_
| FilePath -> UnqualComponentName
mkUnqualComponentName FilePath
bmName UnqualComponentName -> [UnqualComponentName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UnqualComponentName]
allNames ->
Verbosity
-> CabalException -> IO (Benchmark, ComponentLocalBuildInfo)
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO (Benchmark, ComponentLocalBuildInfo))
-> CabalException -> IO (Benchmark, ComponentLocalBuildInfo)
forall a b. (a -> b) -> a -> b
$ FilePath -> CabalException
BenchMarkNameDisabled FilePath
bmName
| Bool
otherwise -> Verbosity
-> CabalException -> IO (Benchmark, ComponentLocalBuildInfo)
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO (Benchmark, ComponentLocalBuildInfo))
-> CabalException -> IO (Benchmark, ComponentLocalBuildInfo)
forall a b. (a -> b) -> a -> b
$ FilePath -> CabalException
NoBenchMark FilePath
bmName
let totalBenchmarks :: Int
totalBenchmarks = [(Benchmark, ComponentLocalBuildInfo)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Benchmark, ComponentLocalBuildInfo)]
bmsToRun
Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Running " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
totalBenchmarks FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" benchmarks..."
[ExitCode]
exitcodes <- ((Benchmark, ComponentLocalBuildInfo) -> IO ExitCode)
-> [(Benchmark, ComponentLocalBuildInfo)] -> IO [ExitCode]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Benchmark, ComponentLocalBuildInfo) -> IO ExitCode
doBench [(Benchmark, ComponentLocalBuildInfo)]
bmsToRun
let allOk :: Bool
allOk = Int
totalBenchmarks Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [ExitCode] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((ExitCode -> Bool) -> [ExitCode] -> [ExitCode]
forall a. (a -> Bool) -> [a] -> [a]
filter (ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess) [ExitCode]
exitcodes)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
allOk IO ()
forall a. IO a
exitFailure
where
startMessage :: FilePath -> FilePath
startMessage FilePath
name = FilePath
"Benchmark " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": RUNNING...\n"
finishMessage :: FilePath -> ExitCode -> FilePath
finishMessage FilePath
name ExitCode
exitcode =
FilePath
"Benchmark "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
name
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": "
FilePath -> FilePath -> 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 (PathTemplate -> FilePath) -> PathTemplate -> FilePath
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 (Compiler -> CompilerInfo) -> Compiler -> CompilerInfo
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> Compiler
LBI.compiler LocalBuildInfo
lbi)
(LocalBuildInfo -> Platform
LBI.hostPlatform LocalBuildInfo
lbi)
PathTemplateEnv -> PathTemplateEnv -> PathTemplateEnv
forall a. [a] -> [a] -> [a]
++ [(PathTemplateVariable
BenchmarkNameVar, FilePath -> PathTemplate
toPathTemplate (FilePath -> PathTemplate) -> FilePath -> PathTemplate
forall a b. (a -> b) -> a -> b
$ UnqualComponentName -> FilePath
unUnqualComponentName (UnqualComponentName -> FilePath)
-> UnqualComponentName -> FilePath
forall a b. (a -> b) -> a -> b
$ Benchmark -> UnqualComponentName
PD.benchmarkName Benchmark
bm)]