    {-# 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.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
    "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 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] -> Bool
    forall a. [a] -> 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 a. a -> IO a
    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 a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Benchmark
    t
                        Maybe Benchmark
    _ | 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 -> 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 a. [a] -> 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)
    forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> [a] -> f [b]
    traverse 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 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")

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