Cabal/src/Distribution/Simple/Bench.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE RankNTypes #-}
   3
   4 -----------------------------------------------------------------------------
   5
   6 -- |
   7 -- Module      :  Distribution.Simple.Bench
   8 -- Copyright   :  Johan Tibell 2011
   9 -- License     :  BSD3
  10 --
  11 -- Maintainer  :  cabal-devel@haskell.org
  12 -- Portability :  portable
  13 --
  14 -- This is the entry point into running the benchmarks in a built
  15 -- package. It performs the \"@.\/setup bench@\" action. It runs
  16 -- benchmarks designated in the package description.
  17 module Distribution.Simple.Bench
  18   ( bench
  19   ) where
  20
  21 import Distribution.Compat.Prelude
  22 import Prelude ()
  23
  24 import qualified Distribution.PackageDescription as PD
  25 import Distribution.Pretty
  26 import Distribution.Simple.BuildPaths
  27 import Distribution.Simple.Compiler
  28 import Distribution.Simple.Flag (fromFlag)
  29 import Distribution.Simple.InstallDirs
  30 import qualified Distribution.Simple.LocalBuildInfo as LBI
  31 import Distribution.Simple.Setup.Benchmark
  32 import Distribution.Simple.UserHooks
  33 import Distribution.Simple.Utils
  34
  35 import Distribution.Types.UnqualComponentName
  36
  37 import Distribution.Simple.Errors
  38 import System.Directory (doesFileExist)
  39 import System.FilePath ((<.>), (</>))
  40
  41 -- | Perform the \"@.\/setup bench@\" action.
  42 bench
  43   :: Args
  44   -- ^ positional command-line arguments
  45   -> PD.PackageDescription
  46   -- ^ information from the .cabal file
  47   -> LBI.LocalBuildInfo
  48   -- ^ information from the configure step
  49   -> BenchmarkFlags
  50   -- ^ flags sent to benchmark
  51   -> IO ()
  52 bench args pkg_descr lbi flags = do
  53   let verbosity = fromFlag $ benchmarkVerbosity flags
  54       benchmarkNames = args
  55       pkgBenchmarks = PD.benchmarks pkg_descr
  56       enabledBenchmarks = map fst (LBI.enabledBenchLBIs pkg_descr lbi)
  57
  58       -- Run the benchmark
  59       doBench :: PD.Benchmark -> IO ExitCode
  60       doBench bm =
  61         case PD.benchmarkInterface bm of
  62           PD.BenchmarkExeV10 _ _ -> do
  63             let cmd = LBI.buildDir lbi </> name </> name <.> exeExtension (LBI.hostPlatform lbi)
  64                 options =
  65                   map (benchOption pkg_descr lbi bm) $
  66                     benchmarkOptions flags
  67             -- Check that the benchmark executable exists.
  68             exists <- doesFileExist cmd
  69             unless exists $
  70               dieWithException verbosity $
  71                 NoBenchMarkProgram cmd
  72
  73             notice verbosity $ startMessage name
  74             -- This will redirect the child process
  75             -- stdout/stderr to the parent process.
  76             exitcode <- rawSystemExitCode verbosity cmd options
  77             notice verbosity $ finishMessage name exitcode
  78             return exitcode
  79           _ -> do
  80             notice verbosity $
  81               "No support for running "
  82                 ++ "benchmark "
  83                 ++ name
  84                 ++ " of type: "
  85                 ++ prettyShow (PD.benchmarkType bm)
  86             exitFailure
  87         where
  88           name = unUnqualComponentName $ PD.benchmarkName bm
  89
  90   unless (PD.hasBenchmarks pkg_descr) $ do
  91     notice verbosity "Package has no benchmarks."
  92     exitSuccess
  93
  94   when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $
  95     dieWithException verbosity EnableBenchMark
  96
  97   bmsToRun <- case benchmarkNames of
  98     [] -> return enabledBenchmarks
  99     names -> for names $ \bmName ->
 100       let benchmarkMap = zip enabledNames enabledBenchmarks
 101           enabledNames = map PD.benchmarkName enabledBenchmarks
 102           allNames = map PD.benchmarkName pkgBenchmarks
 103        in case lookup (mkUnqualComponentName bmName) benchmarkMap of
 104             Just t -> return t
 105             _
 106               | mkUnqualComponentName bmName `elem` allNames ->
 107                   dieWithException verbosity $ BenchMarkNameDisabled bmName
 108               | otherwise -> dieWithException verbosity $ NoBenchMark bmName
 109
 110   let totalBenchmarks = length bmsToRun
 111   notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..."
 112   exitcodes <- traverse doBench bmsToRun
 113   let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes)
 114   unless allOk exitFailure
 115   where
 116     startMessage name = "Benchmark " ++ name ++ ": RUNNING...\n"
 117     finishMessage name exitcode =
 118       "Benchmark "
 119         ++ name
 120         ++ ": "
 121         ++ ( case exitcode of
 122               ExitSuccess -> "FINISH"
 123               ExitFailure _ -> "ERROR"
 124            )
 125
 126 -- TODO: This is abusing the notion of a 'PathTemplate'.  The result isn't
 127 -- necessarily a path.
 128 benchOption
 129   :: PD.PackageDescription
 130   -> LBI.LocalBuildInfo
 131   -> PD.Benchmark
 132   -> PathTemplate
 133   -> String
 134 benchOption pkg_descr lbi bm template =
 135   fromPathTemplate $ substPathTemplate env template
 136   where
 137     env =
 138       initialPathTemplateEnv
 139         (PD.package pkg_descr)
 140         (LBI.localUnitId lbi)
 141         (compilerInfo $ LBI.compiler lbi)
 142         (LBI.hostPlatform lbi)
 143         ++ [(BenchmarkNameVar, toPathTemplate $ unUnqualComponentName $ PD.benchmarkName bm)]