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