    {-# 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 Distribution.Compat.Prelude
    import Prelude ()

    import qualified Distribution.PackageDescription as PD
    import Distribution.Pretty
    import Distribution.Simple.BuildPaths
    import Distribution.Simple.Compiler
    import Distribution.Simple.Flag (fromFlag)
    import Distribution.Simple.InstallDirs
    import qualified Distribution.Simple.LocalBuildInfo as LBI
    import Distribution.Simple.Setup.Benchmark
    import Distribution.Simple.UserHooks
    import Distribution.Simple.Utils

    import Distribution.Types.UnqualComponentName

    import Distribution.Simple.Errors
    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.
                exists <- FilePath -> IO Bool
    doesFileExist FilePath
    cmd
                unless exists $
                  dieWithException verbosity $
                    NoBenchMarkProgram cmd

                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
              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 -> CabalException -> IO ()
    forall a1 a.
    (HasCallStack, Show a1, Typeable a1,
     Exception (VerboseException a1)) =>
    Verbosity -> a1 -> IO a
    dieWithException Verbosity
    verbosity CabalException
    EnableBenchMark

      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 -> CabalException -> IO Benchmark
    forall a1 a.
    (HasCallStack, Show a1, Typeable a1,
     Exception (VerboseException a1)) =>
    Verbosity -> a1 -> IO a
    dieWithException Verbosity
    verbosity (CabalException -> IO Benchmark) -> CabalException -> IO Benchmark
    forall a b. (a -> b) -> a -> b
    $ FilePath -> CabalException
    BenchMarkNameDisabled FilePath
    bmName
                  | Bool
    otherwise -> Verbosity -> CabalException -> IO Benchmark
    forall a1 a.
    (HasCallStack, Show a1, Typeable a1,
     Exception (VerboseException a1)) =>
    Verbosity -> a1 -> IO a
    dieWithException Verbosity
    verbosity (CabalException -> IO Benchmark) -> CabalException -> IO Benchmark
    forall a b. (a -> b) -> a -> b
    $ FilePath -> CabalException
    NoBenchMark FilePath
    bmName

      let totalBenchmarks = [Benchmark] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Benchmark]
    bmsToRun
      notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..."
      exitcodes <- traverse doBench bmsToRun
      let 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)
      unless allOk 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)]