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