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

   1 {-# LANGUAGE RecordWildCards #-}
   2
   3 -- | cabal-install CLI command: test
   4 --
   5 module Distribution.Client.CmdTest (
   6     -- * The @test@ CLI and action
   7     testCommand,
   8     testAction,
   9
  10     -- * Internals exposed for testing
  11     isSubComponentProblem,
  12     notTestProblem,
  13     noTestsProblem,
  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, targetSelectorFilter, plural,
  24            renderTargetProblem,
  25            renderTargetProblemNoTargets, targetSelectorPluralPkgs )
  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.Setup
  33          ( TestFlags(..), fromFlagOrDefault )
  34 import Distribution.Simple.Command
  35          ( CommandUI(..), usageAlternatives )
  36 import Distribution.Simple.Flag
  37          ( Flag(..) )
  38 import Distribution.Verbosity
  39          ( normal )
  40 import Distribution.Simple.Utils
  41          ( notice, wrapText, die' )
  42
  43 import qualified System.Exit (exitSuccess)
  44
  45
  46 testCommand :: CommandUI (NixStyleFlags ())
  47 testCommand = CommandUI
  48   { commandName         = "v2-test"
  49   , commandSynopsis     = "Run test-suites."
  50   , commandUsage        = usageAlternatives "v2-test" [ "[TARGETS] [FLAGS]" ]
  51   , commandDescription  = Just $ \_ -> wrapText $
  52         "Runs the specified test-suites, first ensuring they are up to "
  53      ++ "date.\n\n"
  54
  55      ++ "Any test-suite in any package in the project can be specified. "
  56      ++ "A package can be specified in which case all the test-suites in the "
  57      ++ "package are run. The default is to run all the test-suites in the "
  58      ++ "package in the current directory.\n\n"
  59
  60      ++ "Dependencies are built or rebuilt as necessary. Additional "
  61      ++ "configuration flags can be specified on the command line and these "
  62      ++ "extend the project configuration from the 'cabal.project', "
  63      ++ "'cabal.project.local' and other files.\n\n"
  64
  65      ++ "To pass command-line arguments to a test suite, see the "
  66      ++ "v2-run command."
  67   , commandNotes        = Just $ \pname ->
  68         "Examples:\n"
  69      ++ "  " ++ pname ++ " v2-test\n"
  70      ++ "    Run all the test-suites in the package in the current directory\n"
  71      ++ "  " ++ pname ++ " v2-test pkgname\n"
  72      ++ "    Run all the test-suites in the package named pkgname\n"
  73      ++ "  " ++ pname ++ " v2-test cname\n"
  74      ++ "    Run the test-suite named cname\n"
  75      ++ "  " ++ pname ++ " v2-test cname --enable-coverage\n"
  76      ++ "    Run the test-suite built with code coverage (including local libs used)\n"
  77
  78   , commandDefaultFlags = defaultNixStyleFlags ()
  79   , commandOptions      = nixStyleOptions (const [])
  80   }
  81
  82
  83
  84 -- | The @test@ command is very much like @build@. It brings the install plan
  85 -- up to date, selects that part of the plan needed by the given or implicit
  86 -- test target(s) and then executes the plan.
  87 --
  88 -- Compared to @build@ the difference is that there's also test targets
  89 -- which are ephemeral.
  90 --
  91 -- For more details on how this works, see the module
  92 -- "Distribution.Client.ProjectOrchestration"
  93 --
  94 testAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
  95 testAction flags@NixStyleFlags {..} targetStrings globalFlags = do
  96
  97     baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand
  98
  99     targetSelectors <- either (reportTargetSelectorProblems verbosity) return
 100                    =<< readTargetSelectors (localPackages baseCtx) (Just TestKind) targetStrings
 101
 102     buildCtx <-
 103       runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
 104
 105             when (buildSettingOnlyDeps (buildSettings baseCtx)) $
 106               die' verbosity $
 107                   "The test command does not support '--only-dependencies'. "
 108                ++ "You may wish to use 'build --only-dependencies' and then "
 109                ++ "use 'test'."
 110
 111             -- Interpret the targets on the command line as test targets
 112             -- (as opposed to say build or haddock targets).
 113             targets <- either (reportTargetProblems verbosity failWhenNoTestSuites) return
 114                      $ resolveTargets
 115                          selectPackageTargets
 116                          selectComponentTarget
 117                          elaboratedPlan
 118                          Nothing
 119                          targetSelectors
 120
 121             let elaboratedPlan' = pruneInstallPlanToTargets
 122                                     TargetActionTest
 123                                     targets
 124                                     elaboratedPlan
 125             return (elaboratedPlan', targets)
 126
 127     printPlan verbosity baseCtx buildCtx
 128
 129     buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx
 130     runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
 131   where
 132     failWhenNoTestSuites = testFailWhenNoTestSuites testFlags
 133     verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
 134     cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags
 135
 136 -- | This defines what a 'TargetSelector' means for the @test@ command.
 137 -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
 138 -- or otherwise classifies the problem.
 139 --
 140 -- For the @test@ command we select all buildable test-suites,
 141 -- or fail if there are no test-suites or no buildable test-suites.
 142 --
 143 selectPackageTargets  :: TargetSelector
 144                       -> [AvailableTarget k] -> Either TestTargetProblem [k]
 145 selectPackageTargets targetSelector targets
 146
 147     -- If there are any buildable test-suite targets then we select those
 148   | not (null targetsTestsBuildable)
 149   = Right targetsTestsBuildable
 150
 151     -- If there are test-suites but none are buildable then we report those
 152   | not (null targetsTests)
 153   = Left (TargetProblemNoneEnabled targetSelector targetsTests)
 154
 155     -- If there are no test-suite but some other targets then we report that
 156   | not (null targets)
 157   = Left (noTestsProblem targetSelector)
 158
 159     -- If there are no targets at all then we report that
 160   | otherwise
 161   = Left (TargetProblemNoTargets targetSelector)
 162   where
 163     targetsTestsBuildable = selectBuildableTargets
 164                           . filterTargetsKind TestKind
 165                           $ targets
 166
 167     targetsTests          = forgetTargetsDetail
 168                           . filterTargetsKind TestKind
 169                           $ targets
 170
 171
 172 -- | For a 'TargetComponent' 'TargetSelector', check if the component can be
 173 -- selected.
 174 --
 175 -- For the @test@ command we just need to check it is a test-suite, in addition
 176 -- to the basic checks on being buildable etc.
 177 --
 178 selectComponentTarget :: SubComponentTarget
 179                       -> AvailableTarget k -> Either TestTargetProblem k
 180 selectComponentTarget subtarget@WholeComponent t
 181   | CTestName _ <- availableTargetComponentName t
 182   = either Left return $
 183            selectComponentTargetBasic subtarget t
 184   | otherwise
 185   = Left (notTestProblem
 186            (availableTargetPackageId t)
 187            (availableTargetComponentName t))
 188
 189 selectComponentTarget subtarget t
 190   = Left (isSubComponentProblem
 191            (availableTargetPackageId t)
 192            (availableTargetComponentName t)
 193            subtarget)
 194
 195 -- | The various error conditions that can occur when matching a
 196 -- 'TargetSelector' against 'AvailableTarget's for the @test@ command.
 197 --
 198 data TestProblem =
 199      -- | The 'TargetSelector' matches targets but no test-suites
 200      TargetProblemNoTests     TargetSelector
 201
 202      -- | The 'TargetSelector' refers to a component that is not a test-suite
 203    | TargetProblemComponentNotTest PackageId ComponentName
 204
 205      -- | Asking to test an individual file or module is not supported
 206    | TargetProblemIsSubComponent   PackageId ComponentName SubComponentTarget
 207   deriving (Eq, Show)
 208
 209
 210 type TestTargetProblem = TargetProblem TestProblem
 211
 212
 213 noTestsProblem :: TargetSelector -> TargetProblem TestProblem
 214 noTestsProblem = CustomTargetProblem . TargetProblemNoTests
 215
 216 notTestProblem :: PackageId -> ComponentName -> TargetProblem TestProblem
 217 notTestProblem pkgid name = CustomTargetProblem $ TargetProblemComponentNotTest pkgid name
 218
 219 isSubComponentProblem
 220   :: PackageId
 221   -> ComponentName
 222   -> SubComponentTarget
 223   -> TargetProblem TestProblem
 224 isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $
 225   TargetProblemIsSubComponent pkgid name subcomponent
 226
 227 reportTargetProblems :: Verbosity -> Flag Bool -> [TestTargetProblem] -> IO a
 228 reportTargetProblems verbosity failWhenNoTestSuites problems =
 229   case (failWhenNoTestSuites, problems) of
 230     (Flag True, [CustomTargetProblem (TargetProblemNoTests _)]) ->
 231       die' verbosity problemsMessage
 232     (_, [CustomTargetProblem (TargetProblemNoTests selector)]) -> do
 233       notice verbosity (renderAllowedNoTestsProblem selector)
 234       System.Exit.exitSuccess
 235     (_, _) -> die' verbosity problemsMessage
 236     where
 237       problemsMessage = unlines . map renderTestTargetProblem $ problems
 238
 239 -- | Unless @--test-fail-when-no-test-suites@ flag is passed, we don't
 240 --   @die@ when the target problem is 'TargetProblemNoTests'.
 241 --   Instead, we display a notice saying that no tests have run and
 242 --   indicate how this behaviour was enabled.
 243 renderAllowedNoTestsProblem :: TargetSelector -> String
 244 renderAllowedNoTestsProblem selector =
 245     "No tests to run for " ++ renderTargetSelector selector
 246
 247 renderTestTargetProblem :: TestTargetProblem -> String
 248 renderTestTargetProblem (TargetProblemNoTargets targetSelector) =
 249     case targetSelectorFilter targetSelector of
 250       Just kind | kind /= TestKind
 251         -> "The test command is for running test suites, but the target '"
 252            ++ showTargetSelector targetSelector ++ "' refers to "
 253            ++ renderTargetSelector targetSelector ++ "."
 254            ++ "\n" ++ show targetSelector
 255
 256       _ -> renderTargetProblemNoTargets "test" targetSelector
 257 renderTestTargetProblem problem =
 258     renderTargetProblem "test" renderTestProblem problem
 259
 260
 261 renderTestProblem :: TestProblem -> String
 262 renderTestProblem (TargetProblemNoTests targetSelector) =
 263     "Cannot run tests for the target '" ++ showTargetSelector targetSelector
 264  ++ "' which refers to " ++ renderTargetSelector targetSelector
 265  ++ " because "
 266  ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"
 267  ++ " not contain any test suites."
 268
 269 renderTestProblem (TargetProblemComponentNotTest pkgid cname) =
 270     "The test command is for running test suites, but the target '"
 271  ++ showTargetSelector targetSelector ++ "' refers to "
 272  ++ renderTargetSelector targetSelector ++ " from the package "
 273  ++ prettyShow pkgid ++ "."
 274   where
 275     targetSelector = TargetComponent pkgid cname WholeComponent
 276
 277 renderTestProblem (TargetProblemIsSubComponent pkgid cname subtarget) =
 278     "The test command can only run test suites as a whole, "
 279  ++ "not files or modules within them, but the target '"
 280  ++ showTargetSelector targetSelector ++ "' refers to "
 281  ++ renderTargetSelector targetSelector ++ "."
 282   where
 283     targetSelector = TargetComponent pkgid cname subtarget