cabal-install/src/Distribution/Client/CmdBench.hs

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