1{-# LANGUAGE NamedFieldPuns #-} 2 3-- | cabal-install CLI command: bench 4-- 5module Distribution.Client.CmdBench ( 6 -- * The @bench@ CLI and action 7 benchCommand, 8 benchAction, 9 10 -- * Internals exposed for testing 11 TargetProblem(..), 12 selectPackageTargets, 13 selectComponentTarget 14 ) where 15 16import Distribution.Client.ProjectOrchestration 17import Distribution.Client.CmdErrorMessages 18 19import Distribution.Client.Setup 20 ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) 21import qualified Distribution.Client.Setup as Client 22import Distribution.Simple.Setup 23 ( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault ) 24import Distribution.Simple.Command 25 ( CommandUI(..), usageAlternatives ) 26import Distribution.Deprecated.Text 27 ( display ) 28import Distribution.Verbosity 29 ( Verbosity, normal ) 30import Distribution.Simple.Utils 31 ( wrapText, die' ) 32 33import Control.Monad (when) 34 35 36benchCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags 37 , HaddockFlags, TestFlags, BenchmarkFlags 38 ) 39benchCommand = Client.installCommand { 40 commandName = "v2-bench", 41 commandSynopsis = "Run benchmarks", 42 commandUsage = usageAlternatives "v2-bench" [ "[TARGETS] [FLAGS]" ], 43 commandDescription = Just $ \_ -> wrapText $ 44 "Runs the specified benchmarks, first ensuring they are up to " 45 ++ "date.\n\n" 46 47 ++ "Any benchmark in any package in the project can be specified. " 48 ++ "A package can be specified in which case all the benchmarks in the " 49 ++ "package are run. The default is to run all the benchmarks in the " 50 ++ "package in the current directory.\n\n" 51 52 ++ "Dependencies are built or rebuilt as necessary. Additional " 53 ++ "configuration flags can be specified on the command line and these " 54 ++ "extend the project configuration from the 'cabal.project', " 55 ++ "'cabal.project.local' and other files.", 56 commandNotes = Just $ \pname -> 57 "Examples:\n" 58 ++ " " ++ pname ++ " v2-bench\n" 59 ++ " Run all the benchmarks in the package in the current directory\n" 60 ++ " " ++ pname ++ " v2-bench pkgname\n" 61 ++ " Run all the benchmarks in the package named pkgname\n" 62 ++ " " ++ pname ++ " v2-bench cname\n" 63 ++ " Run the benchmark named cname\n" 64 ++ " " ++ pname ++ " v2-bench cname -O2\n" 65 ++ " Run the benchmark built with '-O2' (including local libs used)\n\n" 66 67 ++ cmdCommonHelpTextNewBuildBeta 68 } 69 70 71-- | The @build@ command does a lot. It brings the install plan up to date, 72-- selects that part of the plan needed by the given or implicit targets and 73-- then executes the plan. 74-- 75-- For more details on how this works, see the module 76-- "Distribution.Client.ProjectOrchestration" 77-- 78benchAction :: ( ConfigFlags, ConfigExFlags, InstallFlags 79 , HaddockFlags, TestFlags, BenchmarkFlags ) 80 -> [String] -> GlobalFlags -> IO () 81benchAction ( configFlags, configExFlags, installFlags 82 , haddockFlags, testFlags, benchmarkFlags ) 83 targetStrings globalFlags = do 84 85 baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand 86 87 targetSelectors <- either (reportTargetSelectorProblems verbosity) return 88 =<< readTargetSelectors (localPackages baseCtx) (Just BenchKind) targetStrings 89 90 buildCtx <- 91 runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do 92 93 when (buildSettingOnlyDeps (buildSettings baseCtx)) $ 94 die' verbosity $ 95 "The bench command does not support '--only-dependencies'. " 96 ++ "You may wish to use 'build --only-dependencies' and then " 97 ++ "use 'bench'." 98 99 -- Interpret the targets on the command line as bench targets 100 -- (as opposed to say build or haddock targets). 101 targets <- either (reportTargetProblems verbosity) return 102 $ resolveTargets 103 selectPackageTargets 104 selectComponentTarget 105 TargetProblemCommon 106 elaboratedPlan 107 Nothing 108 targetSelectors 109 110 let elaboratedPlan' = pruneInstallPlanToTargets 111 TargetActionBench 112 targets 113 elaboratedPlan 114 return (elaboratedPlan', targets) 115 116 printPlan verbosity baseCtx buildCtx 117 118 buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx 119 runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes 120 where 121 verbosity = fromFlagOrDefault normal (configVerbosity configFlags) 122 cliConfig = commandLineFlagsToProjectConfig 123 globalFlags configFlags configExFlags 124 installFlags 125 mempty -- ClientInstallFlags, not needed here 126 haddockFlags testFlags benchmarkFlags 127 128-- | This defines what a 'TargetSelector' means for the @bench@ command. 129-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, 130-- or otherwise classifies the problem. 131-- 132-- For the @bench@ command we select all buildable benchmarks, 133-- or fail if there are no benchmarks or no buildable benchmarks. 134-- 135selectPackageTargets :: TargetSelector 136 -> [AvailableTarget k] -> Either TargetProblem [k] 137selectPackageTargets targetSelector targets 138 139 -- If there are any buildable benchmark targets then we select those 140 | not (null targetsBenchBuildable) 141 = Right targetsBenchBuildable 142 143 -- If there are benchmarks but none are buildable then we report those 144 | not (null targetsBench) 145 = Left (TargetProblemNoneEnabled targetSelector targetsBench) 146 147 -- If there are no benchmarks but some other targets then we report that 148 | not (null targets) 149 = Left (TargetProblemNoBenchmarks targetSelector) 150 151 -- If there are no targets at all then we report that 152 | otherwise 153 = Left (TargetProblemNoTargets targetSelector) 154 where 155 targetsBenchBuildable = selectBuildableTargets 156 . filterTargetsKind BenchKind 157 $ targets 158 159 targetsBench = forgetTargetsDetail 160 . filterTargetsKind BenchKind 161 $ targets 162 163 164-- | For a 'TargetComponent' 'TargetSelector', check if the component can be 165-- selected. 166-- 167-- For the @bench@ command we just need to check it is a benchmark, in addition 168-- to the basic checks on being buildable etc. 169-- 170selectComponentTarget :: SubComponentTarget 171 -> AvailableTarget k -> Either TargetProblem k 172selectComponentTarget subtarget@WholeComponent t 173 | CBenchName _ <- availableTargetComponentName t 174 = either (Left . TargetProblemCommon) return $ 175 selectComponentTargetBasic subtarget t 176 | otherwise 177 = Left (TargetProblemComponentNotBenchmark (availableTargetPackageId t) 178 (availableTargetComponentName t)) 179 180selectComponentTarget subtarget t 181 = Left (TargetProblemIsSubComponent (availableTargetPackageId t) 182 (availableTargetComponentName t) 183 subtarget) 184 185-- | The various error conditions that can occur when matching a 186-- 'TargetSelector' against 'AvailableTarget's for the @bench@ command. 187-- 188data TargetProblem = 189 TargetProblemCommon TargetProblemCommon 190 191 -- | The 'TargetSelector' matches benchmarks but none are buildable 192 | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] 193 194 -- | There are no targets at all 195 | TargetProblemNoTargets TargetSelector 196 197 -- | The 'TargetSelector' matches targets but no benchmarks 198 | TargetProblemNoBenchmarks TargetSelector 199 200 -- | The 'TargetSelector' refers to a component that is not a benchmark 201 | TargetProblemComponentNotBenchmark PackageId ComponentName 202 203 -- | Asking to benchmark an individual file or module is not supported 204 | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget 205 deriving (Eq, Show) 206 207reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a 208reportTargetProblems verbosity = 209 die' verbosity . unlines . map renderTargetProblem 210 211renderTargetProblem :: TargetProblem -> String 212renderTargetProblem (TargetProblemCommon problem) = 213 renderTargetProblemCommon "run" problem 214 215renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) = 216 renderTargetProblemNoneEnabled "benchmark" targetSelector targets 217 218renderTargetProblem (TargetProblemNoBenchmarks targetSelector) = 219 "Cannot run benchmarks for the target '" ++ showTargetSelector targetSelector 220 ++ "' which refers to " ++ renderTargetSelector targetSelector 221 ++ " because " 222 ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do" 223 ++ " not contain any benchmarks." 224 225renderTargetProblem (TargetProblemNoTargets targetSelector) = 226 case targetSelectorFilter targetSelector of 227 Just kind | kind /= BenchKind 228 -> "The bench command is for running benchmarks, but the target '" 229 ++ showTargetSelector targetSelector ++ "' refers to " 230 ++ renderTargetSelector targetSelector ++ "." 231 232 _ -> renderTargetProblemNoTargets "benchmark" targetSelector 233 234renderTargetProblem (TargetProblemComponentNotBenchmark pkgid cname) = 235 "The bench command is for running benchmarks, but the target '" 236 ++ showTargetSelector targetSelector ++ "' refers to " 237 ++ renderTargetSelector targetSelector ++ " from the package " 238 ++ display pkgid ++ "." 239 where 240 targetSelector = TargetComponent pkgid cname WholeComponent 241 242renderTargetProblem (TargetProblemIsSubComponent pkgid cname subtarget) = 243 "The bench command can only run benchmarks as a whole, " 244 ++ "not files or modules within them, but the target '" 245 ++ showTargetSelector targetSelector ++ "' refers to " 246 ++ renderTargetSelector targetSelector ++ "." 247 where 248 targetSelector = TargetComponent pkgid cname subtarget 249