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

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