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