{-# LANGUAGE RecordWildCards #-}

-- | cabal-install CLI command: bench
module Distribution.Client.CmdBench
  ( -- * The @bench@ CLI and action
    benchCommand
  , benchAction

    -- * Internals exposed for testing
  , componentNotBenchmarkProblem
  , isSubComponentProblem
  , noBenchmarksProblem
  , selectPackageTargets
  , selectComponentTarget
  ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import Distribution.Client.CmdErrorMessages
  ( plural
  , renderTargetProblem
  , renderTargetProblemNoTargets
  , renderTargetSelector
  , showTargetSelector
  , targetSelectorFilter
  , targetSelectorPluralPkgs
  )
import Distribution.Client.Errors
import Distribution.Client.NixStyleOptions
  ( NixStyleFlags (..)
  , defaultNixStyleFlags
  , nixStyleOptions
  )
import Distribution.Client.ProjectOrchestration
import Distribution.Client.Setup
  ( ConfigFlags (..)
  , GlobalFlags
  )
import Distribution.Client.TargetProblem
  ( TargetProblem (..)
  )
import Distribution.Client.Utils
  ( giveRTSWarning
  )
import Distribution.Simple.Command
  ( CommandUI (..)
  , usageAlternatives
  )
import Distribution.Simple.Flag
  ( fromFlagOrDefault
  )
import Distribution.Simple.Setup (CommonSetupFlags (..))
import Distribution.Simple.Utils
  ( dieWithException
  , warn
  , wrapText
  )
import Distribution.Verbosity
  ( normal
  )

import GHC.Environment
  ( getFullArgs
  )

benchCommand :: CommandUI (NixStyleFlags ())
benchCommand :: CommandUI (NixStyleFlags ())
benchCommand =
  CommandUI
    { commandName :: String
commandName = String
"v2-bench"
    , commandSynopsis :: String
commandSynopsis = String
"Run benchmarks."
    , commandUsage :: String -> String
commandUsage = String -> [String] -> String -> String
usageAlternatives String
"v2-bench" [String
"[TARGETS] [FLAGS]"]
    , commandDescription :: Maybe (String -> String)
commandDescription = (String -> String) -> Maybe (String -> String)
forall a. a -> Maybe a
Just ((String -> String) -> Maybe (String -> String))
-> (String -> String) -> Maybe (String -> String)
forall a b. (a -> b) -> a -> b
$ \String
_ ->
        String -> String
wrapText (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
          String
"Runs the specified benchmarks, first ensuring they are up to "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"date.\n\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Any benchmark in any package in the project can be specified. "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"A package can be specified in which case all the benchmarks in the "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"package are run. The default is to run all the benchmarks in the "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"package in the current directory.\n\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Dependencies are built or rebuilt as necessary. Additional "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"configuration flags can be specified on the command line and these "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"extend the project configuration from the 'cabal.project', "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'cabal.project.local' and other files."
    , commandNotes :: Maybe (String -> String)
commandNotes = (String -> String) -> Maybe (String -> String)
forall a. a -> Maybe a
Just ((String -> String) -> Maybe (String -> String))
-> (String -> String) -> Maybe (String -> String)
forall a b. (a -> b) -> a -> b
$ \String
pname ->
        String
"Examples:\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" v2-bench\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    Run all the benchmarks in the package in the current directory\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" v2-bench pkgname\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    Run all the benchmarks in the package named pkgname\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" v2-bench cname\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    Run the benchmark named cname\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" v2-bench cname -O2\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    Run the benchmark built with '-O2' (including local libs used)\n"
    , commandDefaultFlags :: NixStyleFlags ()
commandDefaultFlags = () -> NixStyleFlags ()
forall a. a -> NixStyleFlags a
defaultNixStyleFlags ()
    , commandOptions :: ShowOrParseArgs -> [OptionField (NixStyleFlags ())]
commandOptions = (ShowOrParseArgs -> [OptionField ()])
-> ShowOrParseArgs -> [OptionField (NixStyleFlags ())]
forall a.
(ShowOrParseArgs -> [OptionField a])
-> ShowOrParseArgs -> [OptionField (NixStyleFlags a)]
nixStyleOptions ([OptionField ()] -> ShowOrParseArgs -> [OptionField ()]
forall a b. a -> b -> a
const [])
    }

-- | The @build@ command does a lot. It brings the install plan up to date,
-- selects that part of the plan needed by the given or implicit targets and
-- then executes the plan.
--
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
benchAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
benchAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
benchAction flags :: NixStyleFlags ()
flags@NixStyleFlags{()
TestFlags
HaddockFlags
ConfigFlags
BenchmarkFlags
ProjectFlags
InstallFlags
ConfigExFlags
configFlags :: ConfigFlags
configExFlags :: ConfigExFlags
installFlags :: InstallFlags
haddockFlags :: HaddockFlags
testFlags :: TestFlags
benchmarkFlags :: BenchmarkFlags
projectFlags :: ProjectFlags
extraFlags :: ()
configFlags :: forall a. NixStyleFlags a -> ConfigFlags
configExFlags :: forall a. NixStyleFlags a -> ConfigExFlags
installFlags :: forall a. NixStyleFlags a -> InstallFlags
haddockFlags :: forall a. NixStyleFlags a -> HaddockFlags
testFlags :: forall a. NixStyleFlags a -> TestFlags
benchmarkFlags :: forall a. NixStyleFlags a -> BenchmarkFlags
projectFlags :: forall a. NixStyleFlags a -> ProjectFlags
extraFlags :: forall a. NixStyleFlags a -> a
..} [String]
targetStrings GlobalFlags
globalFlags = do
  ProjectBaseContext
baseCtx <- Verbosity
-> ProjectConfig -> CurrentCommand -> IO ProjectBaseContext
establishProjectBaseContext Verbosity
verbosity ProjectConfig
cliConfig CurrentCommand
OtherCommand

  [TargetSelector]
targetSelectors <-
    ([TargetSelectorProblem] -> IO [TargetSelector])
-> ([TargetSelector] -> IO [TargetSelector])
-> Either [TargetSelectorProblem] [TargetSelector]
-> IO [TargetSelector]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Verbosity -> [TargetSelectorProblem] -> IO [TargetSelector]
forall a. Verbosity -> [TargetSelectorProblem] -> IO a
reportTargetSelectorProblems Verbosity
verbosity) [TargetSelector] -> IO [TargetSelector]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
      (Either [TargetSelectorProblem] [TargetSelector]
 -> IO [TargetSelector])
-> IO (Either [TargetSelectorProblem] [TargetSelector])
-> IO [TargetSelector]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [PackageSpecifier (SourcePackage (PackageLocation (Maybe String)))]
-> Maybe ComponentKindFilter
-> [String]
-> IO (Either [TargetSelectorProblem] [TargetSelector])
forall a.
[PackageSpecifier (SourcePackage (PackageLocation a))]
-> Maybe ComponentKindFilter
-> [String]
-> IO (Either [TargetSelectorProblem] [TargetSelector])
readTargetSelectors (ProjectBaseContext
-> [PackageSpecifier
      (SourcePackage (PackageLocation (Maybe String)))]
localPackages ProjectBaseContext
baseCtx) (ComponentKindFilter -> Maybe ComponentKindFilter
forall a. a -> Maybe a
Just ComponentKindFilter
BenchKind) [String]
targetStrings

  ProjectBuildContext
buildCtx <-
    Verbosity
-> ProjectBaseContext
-> (ElaboratedInstallPlan
    -> IO (ElaboratedInstallPlan, TargetsMap))
-> IO ProjectBuildContext
runProjectPreBuildPhase Verbosity
verbosity ProjectBaseContext
baseCtx ((ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap))
 -> IO ProjectBuildContext)
-> (ElaboratedInstallPlan
    -> IO (ElaboratedInstallPlan, TargetsMap))
-> IO ProjectBuildContext
forall a b. (a -> b) -> a -> b
$ \ElaboratedInstallPlan
elaboratedPlan -> do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BuildTimeSettings -> Bool
buildSettingOnlyDeps (ProjectBaseContext -> BuildTimeSettings
buildSettings ProjectBaseContext
baseCtx)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalInstallException
BenchActionException

      [String]
fullArgs <- IO [String]
getFullArgs
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
"+RTS" String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
fullArgs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          String -> String
giveRTSWarning String
"bench"

      -- Interpret the targets on the command line as bench targets
      -- (as opposed to say build or haddock targets).
      TargetsMap
targets <-
        ([BenchTargetProblem] -> IO TargetsMap)
-> (TargetsMap -> IO TargetsMap)
-> Either [BenchTargetProblem] TargetsMap
-> IO TargetsMap
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Verbosity -> [BenchTargetProblem] -> IO TargetsMap
forall a. Verbosity -> [BenchTargetProblem] -> IO a
reportTargetProblems Verbosity
verbosity) TargetsMap -> IO TargetsMap
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [BenchTargetProblem] TargetsMap -> IO TargetsMap)
-> Either [BenchTargetProblem] TargetsMap -> IO TargetsMap
forall a b. (a -> b) -> a -> b
$
          (forall k.
 TargetSelector
 -> [AvailableTarget k] -> Either BenchTargetProblem [k])
-> (forall k.
    SubComponentTarget
    -> AvailableTarget k -> Either BenchTargetProblem k)
-> ElaboratedInstallPlan
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [BenchTargetProblem] TargetsMap
forall err.
(forall k.
 TargetSelector
 -> [AvailableTarget k] -> Either (TargetProblem err) [k])
-> (forall k.
    SubComponentTarget
    -> AvailableTarget k -> Either (TargetProblem err) k)
-> ElaboratedInstallPlan
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem err] TargetsMap
resolveTargets
            TargetSelector
-> [AvailableTarget k] -> Either BenchTargetProblem [k]
forall k.
TargetSelector
-> [AvailableTarget k] -> Either BenchTargetProblem [k]
selectPackageTargets
            SubComponentTarget
-> AvailableTarget k -> Either BenchTargetProblem k
forall k.
SubComponentTarget
-> AvailableTarget k -> Either BenchTargetProblem k
selectComponentTarget
            ElaboratedInstallPlan
elaboratedPlan
            Maybe SourcePackageDb
forall a. Maybe a
Nothing
            [TargetSelector]
targetSelectors

      let elaboratedPlan' :: ElaboratedInstallPlan
elaboratedPlan' =
            TargetAction
-> TargetsMap -> ElaboratedInstallPlan -> ElaboratedInstallPlan
pruneInstallPlanToTargets
              TargetAction
TargetActionBench
              TargetsMap
targets
              ElaboratedInstallPlan
elaboratedPlan
      (ElaboratedInstallPlan, TargetsMap)
-> IO (ElaboratedInstallPlan, TargetsMap)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ElaboratedInstallPlan
elaboratedPlan', TargetsMap
targets)

  Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO ()
printPlan Verbosity
verbosity ProjectBaseContext
baseCtx ProjectBuildContext
buildCtx

  BuildOutcomes
buildOutcomes <- Verbosity
-> ProjectBaseContext -> ProjectBuildContext -> IO BuildOutcomes
runProjectBuildPhase Verbosity
verbosity ProjectBaseContext
baseCtx ProjectBuildContext
buildCtx
  Verbosity
-> ProjectBaseContext
-> ProjectBuildContext
-> BuildOutcomes
-> IO ()
runProjectPostBuildPhase Verbosity
verbosity ProjectBaseContext
baseCtx ProjectBuildContext
buildCtx BuildOutcomes
buildOutcomes
  where
    verbosity :: Verbosity
verbosity = Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (CommonSetupFlags -> Flag Verbosity
setupVerbosity (CommonSetupFlags -> Flag Verbosity)
-> CommonSetupFlags -> Flag Verbosity
forall a b. (a -> b) -> a -> b
$ ConfigFlags -> CommonSetupFlags
configCommonFlags ConfigFlags
configFlags)
    cliConfig :: ProjectConfig
cliConfig =
      GlobalFlags
-> NixStyleFlags () -> ClientInstallFlags -> ProjectConfig
forall a.
GlobalFlags
-> NixStyleFlags a -> ClientInstallFlags -> ProjectConfig
commandLineFlagsToProjectConfig
        GlobalFlags
globalFlags
        NixStyleFlags ()
flags
        ClientInstallFlags
forall a. Monoid a => a
mempty -- ClientInstallFlags, not needed here

-- | This defines what a 'TargetSelector' means for the @bench@ command.
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
-- or otherwise classifies the problem.
--
-- For the @bench@ command we select all buildable benchmarks,
-- or fail if there are no benchmarks or no buildable benchmarks.
selectPackageTargets
  :: TargetSelector
  -> [AvailableTarget k]
  -> Either BenchTargetProblem [k]
selectPackageTargets :: forall k.
TargetSelector
-> [AvailableTarget k] -> Either BenchTargetProblem [k]
selectPackageTargets TargetSelector
targetSelector [AvailableTarget k]
targets
  -- If there are any buildable benchmark targets then we select those
  | Bool -> Bool
not ([k] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [k]
targetsBenchBuildable) =
      [k] -> Either BenchTargetProblem [k]
forall a b. b -> Either a b
Right [k]
targetsBenchBuildable
  -- If there are benchmarks but none are buildable then we report those
  | Bool -> Bool
not ([AvailableTarget ()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AvailableTarget ()]
targetsBench) =
      BenchTargetProblem -> Either BenchTargetProblem [k]
forall a b. a -> Either a b
Left (TargetSelector -> [AvailableTarget ()] -> BenchTargetProblem
forall a. TargetSelector -> [AvailableTarget ()] -> TargetProblem a
TargetProblemNoneEnabled TargetSelector
targetSelector [AvailableTarget ()]
targetsBench)
  -- If there are no benchmarks but some other targets then we report that
  | Bool -> Bool
not ([AvailableTarget k] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AvailableTarget k]
targets) =
      BenchTargetProblem -> Either BenchTargetProblem [k]
forall a b. a -> Either a b
Left (TargetSelector -> BenchTargetProblem
noBenchmarksProblem TargetSelector
targetSelector)
  -- If there are no targets at all then we report that
  | Bool
otherwise =
      BenchTargetProblem -> Either BenchTargetProblem [k]
forall a b. a -> Either a b
Left (TargetSelector -> BenchTargetProblem
forall a. TargetSelector -> TargetProblem a
TargetProblemNoTargets TargetSelector
targetSelector)
  where
    targetsBenchBuildable :: [k]
targetsBenchBuildable =
      [AvailableTarget k] -> [k]
forall k. [AvailableTarget k] -> [k]
selectBuildableTargets
        ([AvailableTarget k] -> [k])
-> ([AvailableTarget k] -> [AvailableTarget k])
-> [AvailableTarget k]
-> [k]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComponentKindFilter -> [AvailableTarget k] -> [AvailableTarget k]
forall k.
ComponentKindFilter -> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKind ComponentKindFilter
BenchKind
        ([AvailableTarget k] -> [k]) -> [AvailableTarget k] -> [k]
forall a b. (a -> b) -> a -> b
$ [AvailableTarget k]
targets

    targetsBench :: [AvailableTarget ()]
targetsBench =
      [AvailableTarget k] -> [AvailableTarget ()]
forall k. [AvailableTarget k] -> [AvailableTarget ()]
forgetTargetsDetail
        ([AvailableTarget k] -> [AvailableTarget ()])
-> ([AvailableTarget k] -> [AvailableTarget k])
-> [AvailableTarget k]
-> [AvailableTarget ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComponentKindFilter -> [AvailableTarget k] -> [AvailableTarget k]
forall k.
ComponentKindFilter -> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKind ComponentKindFilter
BenchKind
        ([AvailableTarget k] -> [AvailableTarget ()])
-> [AvailableTarget k] -> [AvailableTarget ()]
forall a b. (a -> b) -> a -> b
$ [AvailableTarget k]
targets

-- | For a 'TargetComponent' 'TargetSelector', check if the component can be
-- selected.
--
-- For the @bench@ command we just need to check it is a benchmark, in addition
-- to the basic checks on being buildable etc.
selectComponentTarget
  :: SubComponentTarget
  -> AvailableTarget k
  -> Either BenchTargetProblem k
selectComponentTarget :: forall k.
SubComponentTarget
-> AvailableTarget k -> Either BenchTargetProblem k
selectComponentTarget subtarget :: SubComponentTarget
subtarget@SubComponentTarget
WholeComponent AvailableTarget k
t
  | CBenchName UnqualComponentName
_ <- AvailableTarget k -> ComponentName
forall k. AvailableTarget k -> ComponentName
availableTargetComponentName AvailableTarget k
t =
      SubComponentTarget
-> AvailableTarget k -> Either BenchTargetProblem k
forall k a.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem a) k
selectComponentTargetBasic SubComponentTarget
subtarget AvailableTarget k
t
  | Bool
otherwise =
      BenchTargetProblem -> Either BenchTargetProblem k
forall a b. a -> Either a b
Left
        ( PackageId -> ComponentName -> BenchTargetProblem
componentNotBenchmarkProblem
            (AvailableTarget k -> PackageId
forall k. AvailableTarget k -> PackageId
availableTargetPackageId AvailableTarget k
t)
            (AvailableTarget k -> ComponentName
forall k. AvailableTarget k -> ComponentName
availableTargetComponentName AvailableTarget k
t)
        )
selectComponentTarget SubComponentTarget
subtarget AvailableTarget k
t =
  BenchTargetProblem -> Either BenchTargetProblem k
forall a b. a -> Either a b
Left
    ( PackageId
-> ComponentName -> SubComponentTarget -> BenchTargetProblem
isSubComponentProblem
        (AvailableTarget k -> PackageId
forall k. AvailableTarget k -> PackageId
availableTargetPackageId AvailableTarget k
t)
        (AvailableTarget k -> ComponentName
forall k. AvailableTarget k -> ComponentName
availableTargetComponentName AvailableTarget k
t)
        SubComponentTarget
subtarget
    )

-- | The various error conditions that can occur when matching a
-- 'TargetSelector' against 'AvailableTarget's for the @bench@ command.
data BenchProblem
  = -- | The 'TargetSelector' matches targets but no benchmarks
    TargetProblemNoBenchmarks TargetSelector
  | -- | The 'TargetSelector' refers to a component that is not a benchmark
    TargetProblemComponentNotBenchmark PackageId ComponentName
  | -- | Asking to benchmark an individual file or module is not supported
    TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget
  deriving (BenchProblem -> BenchProblem -> Bool
(BenchProblem -> BenchProblem -> Bool)
-> (BenchProblem -> BenchProblem -> Bool) -> Eq BenchProblem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BenchProblem -> BenchProblem -> Bool
== :: BenchProblem -> BenchProblem -> Bool
$c/= :: BenchProblem -> BenchProblem -> Bool
/= :: BenchProblem -> BenchProblem -> Bool
Eq, Int -> BenchProblem -> String -> String
[BenchProblem] -> String -> String
BenchProblem -> String
(Int -> BenchProblem -> String -> String)
-> (BenchProblem -> String)
-> ([BenchProblem] -> String -> String)
-> Show BenchProblem
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> BenchProblem -> String -> String
showsPrec :: Int -> BenchProblem -> String -> String
$cshow :: BenchProblem -> String
show :: BenchProblem -> String
$cshowList :: [BenchProblem] -> String -> String
showList :: [BenchProblem] -> String -> String
Show)

type BenchTargetProblem = TargetProblem BenchProblem

noBenchmarksProblem :: TargetSelector -> TargetProblem BenchProblem
noBenchmarksProblem :: TargetSelector -> BenchTargetProblem
noBenchmarksProblem = BenchProblem -> BenchTargetProblem
forall a. a -> TargetProblem a
CustomTargetProblem (BenchProblem -> BenchTargetProblem)
-> (TargetSelector -> BenchProblem)
-> TargetSelector
-> BenchTargetProblem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TargetSelector -> BenchProblem
TargetProblemNoBenchmarks

componentNotBenchmarkProblem :: PackageId -> ComponentName -> TargetProblem BenchProblem
componentNotBenchmarkProblem :: PackageId -> ComponentName -> BenchTargetProblem
componentNotBenchmarkProblem PackageId
pkgid ComponentName
name =
  BenchProblem -> BenchTargetProblem
forall a. a -> TargetProblem a
CustomTargetProblem (BenchProblem -> BenchTargetProblem)
-> BenchProblem -> BenchTargetProblem
forall a b. (a -> b) -> a -> b
$
    PackageId -> ComponentName -> BenchProblem
TargetProblemComponentNotBenchmark PackageId
pkgid ComponentName
name

isSubComponentProblem
  :: PackageId
  -> ComponentName
  -> SubComponentTarget
  -> TargetProblem BenchProblem
isSubComponentProblem :: PackageId
-> ComponentName -> SubComponentTarget -> BenchTargetProblem
isSubComponentProblem PackageId
pkgid ComponentName
name SubComponentTarget
subcomponent =
  BenchProblem -> BenchTargetProblem
forall a. a -> TargetProblem a
CustomTargetProblem (BenchProblem -> BenchTargetProblem)
-> BenchProblem -> BenchTargetProblem
forall a b. (a -> b) -> a -> b
$
    PackageId -> ComponentName -> SubComponentTarget -> BenchProblem
TargetProblemIsSubComponent PackageId
pkgid ComponentName
name SubComponentTarget
subcomponent

reportTargetProblems :: Verbosity -> [BenchTargetProblem] -> IO a
reportTargetProblems :: forall a. Verbosity -> [BenchTargetProblem] -> IO a
reportTargetProblems Verbosity
verbosity =
  Verbosity -> CabalInstallException -> IO a
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO a)
-> ([BenchTargetProblem] -> CabalInstallException)
-> [BenchTargetProblem]
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> CabalInstallException
RenderBenchTargetProblem ([String] -> CabalInstallException)
-> ([BenchTargetProblem] -> [String])
-> [BenchTargetProblem]
-> CabalInstallException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BenchTargetProblem -> String) -> [BenchTargetProblem] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map BenchTargetProblem -> String
renderBenchTargetProblem

renderBenchTargetProblem :: BenchTargetProblem -> String
renderBenchTargetProblem :: BenchTargetProblem -> String
renderBenchTargetProblem (TargetProblemNoTargets TargetSelector
targetSelector) =
  case TargetSelector -> Maybe ComponentKindFilter
targetSelectorFilter TargetSelector
targetSelector of
    Just ComponentKindFilter
kind
      | ComponentKindFilter
kind ComponentKindFilter -> ComponentKindFilter -> Bool
forall a. Eq a => a -> a -> Bool
/= ComponentKindFilter
BenchKind ->
          String
"The bench command is for running benchmarks, but the target '"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ TargetSelector -> String
showTargetSelector TargetSelector
targetSelector
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' refers to "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ TargetSelector -> String
renderTargetSelector TargetSelector
targetSelector
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
    Maybe ComponentKindFilter
_ -> String -> TargetSelector -> String
renderTargetProblemNoTargets String
"benchmark" TargetSelector
targetSelector
renderBenchTargetProblem BenchTargetProblem
problem =
  String -> (BenchProblem -> String) -> BenchTargetProblem -> String
forall a. String -> (a -> String) -> TargetProblem a -> String
renderTargetProblem String
"benchmark" BenchProblem -> String
renderBenchProblem BenchTargetProblem
problem

renderBenchProblem :: BenchProblem -> String
renderBenchProblem :: BenchProblem -> String
renderBenchProblem (TargetProblemNoBenchmarks TargetSelector
targetSelector) =
  String
"Cannot run benchmarks for the target '"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ TargetSelector -> String
showTargetSelector TargetSelector
targetSelector
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' which refers to "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ TargetSelector -> String
renderTargetSelector TargetSelector
targetSelector
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" because "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ Plural -> String -> String -> String
forall a. Plural -> a -> a -> a
plural (TargetSelector -> Plural
targetSelectorPluralPkgs TargetSelector
targetSelector) String
"it does" String
"they do"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not contain any benchmarks."
renderBenchProblem (TargetProblemComponentNotBenchmark PackageId
pkgid ComponentName
cname) =
  String
"The bench command is for running benchmarks, but the target '"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ TargetSelector -> String
showTargetSelector TargetSelector
targetSelector
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' refers to "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ TargetSelector -> String
renderTargetSelector TargetSelector
targetSelector
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" from the package "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageId -> String
forall a. Pretty a => a -> String
prettyShow PackageId
pkgid
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
  where
    targetSelector :: TargetSelector
targetSelector = PackageId -> ComponentName -> SubComponentTarget -> TargetSelector
TargetComponent PackageId
pkgid ComponentName
cname SubComponentTarget
WholeComponent
renderBenchProblem (TargetProblemIsSubComponent PackageId
pkgid ComponentName
cname SubComponentTarget
subtarget) =
  String
"The bench command can only run benchmarks as a whole, "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"not files or modules within them, but the target '"
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ TargetSelector -> String
showTargetSelector TargetSelector
targetSelector
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' refers to "
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ TargetSelector -> String
renderTargetSelector TargetSelector
targetSelector
    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
  where
    targetSelector :: TargetSelector
targetSelector = PackageId -> ComponentName -> SubComponentTarget -> TargetSelector
TargetComponent PackageId
pkgid ComponentName
cname SubComponentTarget
subtarget