{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.Bench
-- Copyright   :  Johan Tibell 2011
-- License     :  BSD3
--
-- 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.

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.Exit ( ExitCode(..), exitFailure, exitSuccess )
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
-> 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]
enabledBenchmarks = ((Benchmark, ComponentLocalBuildInfo) -> Benchmark)
-> [(Benchmark, ComponentLocalBuildInfo)] -> [Benchmark]
forall a b. (a -> b) -> [a] -> [b]
map (Benchmark, ComponentLocalBuildInfo) -> Benchmark
forall a b. (a, b) -> a
fst (PackageDescription
-> LocalBuildInfo -> [(Benchmark, ComponentLocalBuildInfo)]
LBI.enabledBenchLBIs PackageDescription
pkg_descr LocalBuildInfo
lbi)

        -- Run the benchmark
        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 = (PathTemplate -> FilePath) -> [PathTemplate] -> Args
forall a b. (a -> b) -> [a] -> [b]
map (PackageDescription
-> LocalBuildInfo -> Benchmark -> PathTemplate -> FilePath
benchOption PackageDescription
pkg_descr LocalBuildInfo
lbi Benchmark
bm) ([PathTemplate] -> Args) -> [PathTemplate] -> Args
forall a b. (a -> b) -> a -> b
$
                                BenchmarkFlags -> [PathTemplate]
benchmarkOptions BenchmarkFlags
flags
                  -- Check that the benchmark executable exists.
                  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 -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
                      FilePath
"Error: Could not find benchmark program \""
                      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
cmd FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\". Did you build the package first?"

                  Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
startMessage FilePath
name
                  -- This will redirect the child process
                  -- stdout/stderr to the parent process.
                  ExitCode
exitcode <- Verbosity -> FilePath -> Args -> IO ExitCode
rawSystemExitCode Verbosity
verbosity FilePath
cmd Args
options
                  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 (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] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Benchmark]
enabledBenchmarks) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"No benchmarks enabled. Did you remember to configure with "
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\'--enable-benchmarks\'?"

    [Benchmark]
bmsToRun <- case Args
benchmarkNames of
            [] -> [Benchmark] -> IO [Benchmark]
forall (m :: * -> *) a. Monad m => a -> m a
return [Benchmark]
enabledBenchmarks
            Args
names -> Args -> (FilePath -> IO Benchmark) -> IO [Benchmark]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Args
names ((FilePath -> IO Benchmark) -> IO [Benchmark])
-> (FilePath -> IO Benchmark) -> IO [Benchmark]
forall a b. (a -> b) -> a -> b
$ \FilePath
bmName ->
                let benchmarkMap :: [(UnqualComponentName, Benchmark)]
benchmarkMap = [UnqualComponentName]
-> [Benchmark] -> [(UnqualComponentName, Benchmark)]
forall a b. [a] -> [b] -> [(a, b)]
zip [UnqualComponentName]
enabledNames [Benchmark]
enabledBenchmarks
                    enabledNames :: [UnqualComponentName]
enabledNames = (Benchmark -> UnqualComponentName)
-> [Benchmark] -> [UnqualComponentName]
forall a b. (a -> b) -> [a] -> [b]
map Benchmark -> UnqualComponentName
PD.benchmarkName [Benchmark]
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)] -> Maybe Benchmark
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (FilePath -> UnqualComponentName
mkUnqualComponentName FilePath
bmName) [(UnqualComponentName, Benchmark)]
benchmarkMap of
                    Just Benchmark
t -> Benchmark -> IO Benchmark
forall (m :: * -> *) a. Monad m => a -> m a
return Benchmark
t
                    Maybe Benchmark
_ | FilePath -> UnqualComponentName
mkUnqualComponentName FilePath
bmName UnqualComponentName -> [UnqualComponentName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UnqualComponentName]
allNames ->
                          Verbosity -> FilePath -> IO Benchmark
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO Benchmark) -> FilePath -> IO Benchmark
forall a b. (a -> b) -> a -> b
$ FilePath
"Package configured with benchmark "
                                FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
bmName FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" disabled."
                      | Bool
otherwise -> Verbosity -> FilePath -> IO Benchmark
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO Benchmark) -> FilePath -> IO Benchmark
forall a b. (a -> b) -> a -> b
$ FilePath
"no such benchmark: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
bmName

    let totalBenchmarks :: Int
totalBenchmarks = [Benchmark] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Benchmark]
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 -> IO ExitCode) -> [Benchmark] -> IO [ExitCode]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Benchmark -> IO ExitCode
Benchmark -> IO ExitCode
doBench [Benchmark]
bmsToRun
    let allOk :: Bool
allOk = Int
totalBenchmarks Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [ExitCode] -> 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")


-- TODO: This is abusing the notion of a 'PathTemplate'.  The result isn't
-- necessarily a path.
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)]